summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclBasic.c46
-rw-r--r--generic/tclEnsemble.c3709
-rw-r--r--generic/tclInt.h4905
-rw-r--r--generic/tclOO.c3073
-rw-r--r--generic/tclProc.c22
-rw-r--r--tests/namespace.test3338
6 files changed, 15053 insertions, 40 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 5b0112d..8a5afd0 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -2270,11 +2270,11 @@ Tcl_CreateObjCommand(
tail = cmdName;
}
- return tclCreateObjCommandInNs(interp, tail, (Tcl_Namespace *) nsPtr,
+ return TclCreateObjCommandInNs(interp, tail, (Tcl_Namespace *) nsPtr,
proc, clientData, deleteProc);
}
-Tcl_Command tclCreateObjCommandInNs (
+Tcl_Command TclCreateObjCommandInNs (
Tcl_Interp *interp,
const char *cmdName, /* Name of command, without any namespace components */
Tcl_Namespace *namespace, /* The namespace to create the command in */
@@ -8192,7 +8192,7 @@ Tcl_NRCreateCommand(
return (Tcl_Command) cmdPtr;
}
-Tcl_Command tclNRCreateCommandInNs (
+Tcl_Command TclNRCreateCommandInNs (
Tcl_Interp *interp,
const char *cmdName,
Tcl_Namespace *nsPtr,
@@ -8201,7 +8201,7 @@ Tcl_Command tclNRCreateCommandInNs (
ClientData clientData,
Tcl_CmdDeleteProc *deleteProc) {
Command *cmdPtr = (Command *)
- tclCreateObjCommandInNs(interp,cmdName,nsPtr,proc,clientData,deleteProc);
+ TclCreateObjCommandInNs(interp,cmdName,nsPtr,proc,clientData,deleteProc);
cmdPtr->nreProc = nreProc;
return (Tcl_Command) cmdPtr;
@@ -8991,9 +8991,9 @@ TclNRCoroutineObjCmd(
{
Command *cmdPtr;
CoroutineData *corPtr;
- const char *fullName, *procName;
- Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
- Tcl_DString ds;
+ const char *procName, *simpleName;
+ Namespace *nsPtr, *altNsPtr, *cxtNsPtr,
+ *inNsPtr = (Namespace *)TclGetCurrentNamespace(interp);
Namespace *lookupNsPtr = iPtr->varFramePtr->nsPtr;
if (objc < 3) {
@@ -9001,27 +9001,22 @@ TclNRCoroutineObjCmd(
return TCL_ERROR;
}
- /*
- * FIXME: this is copy/pasted from Tcl_ProcObjCommand. Should have
- * something in tclUtil.c to find the FQ name.
- */
-
- fullName = TclGetString(objv[1]);
- TclGetNamespaceForQualName(interp, fullName, NULL, 0,
- &nsPtr, &altNsPtr, &cxtNsPtr, &procName);
+ procName = TclGetString(objv[1]);
+ TclGetNamespaceForQualName(interp, procName, inNsPtr, 0,
+ &nsPtr, &altNsPtr, &cxtNsPtr, &simpleName);
if (nsPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create procedure \"%s\": unknown namespace",
- fullName));
+ procName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", NULL);
return TCL_ERROR;
}
- if (procName == NULL) {
+ if (simpleName == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create procedure \"%s\": bad procedure name",
- fullName));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", fullName, NULL);
+ procName));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", procName, NULL);
return TCL_ERROR;
}
@@ -9032,16 +9027,9 @@ TclNRCoroutineObjCmd(
corPtr = ckalloc(sizeof(CoroutineData));
- Tcl_DStringInit(&ds);
- if (nsPtr != iPtr->globalNsPtr) {
- Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
- TclDStringAppendLiteral(&ds, "::");
- }
- Tcl_DStringAppend(&ds, procName, -1);
-
- cmdPtr = (Command *) Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds),
- /*objProc*/ NULL, TclNRInterpCoroutine, corPtr, DeleteCoroutine);
- Tcl_DStringFree(&ds);
+ cmdPtr = (Command *) TclNRCreateCommandInNs(interp, simpleName,
+ (Tcl_Namespace *)nsPtr, /*objProc*/ NULL, TclNRInterpCoroutine,
+ corPtr, DeleteCoroutine);
corPtr->cmdPtr = cmdPtr;
cmdPtr->refCount++;
diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c
new file mode 100644
index 0000000..92c0c76
--- /dev/null
+++ b/generic/tclEnsemble.c
@@ -0,0 +1,3709 @@
+/*
+ * tclEnsemble.c --
+ *
+ * Contains support for ensembles (see TIP#112), which provide simple
+ * mechanism for creating composite commands on top of namespaces.
+ *
+ * Copyright (c) 2005-2013 Donal K. Fellows.
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ */
+
+#include "tclInt.h"
+#include "tclCompile.h"
+
+/*
+ * Declarations for functions local to this file:
+ */
+
+static inline Tcl_Obj * NewNsObj(Tcl_Namespace *namespacePtr);
+static inline int EnsembleUnknownCallback(Tcl_Interp *interp,
+ EnsembleConfig *ensemblePtr, int objc,
+ Tcl_Obj *const objv[], Tcl_Obj **prefixObjPtr);
+static int NsEnsembleImplementationCmd(ClientData clientData,
+ Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
+static int NsEnsembleImplementationCmdNR(ClientData clientData,
+ Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
+static void BuildEnsembleConfig(EnsembleConfig *ensemblePtr);
+static int NsEnsembleStringOrder(const void *strPtr1,
+ const void *strPtr2);
+static void DeleteEnsembleConfig(ClientData clientData);
+static void MakeCachedEnsembleCommand(Tcl_Obj *objPtr,
+ EnsembleConfig *ensemblePtr, Tcl_HashEntry *hPtr,
+ Tcl_Obj *fix);
+static void FreeEnsembleCmdRep(Tcl_Obj *objPtr);
+static void DupEnsembleCmdRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr);
+static void CompileToInvokedCommand(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Tcl_Obj *replacements,
+ Command *cmdPtr, CompileEnv *envPtr);
+static int CompileBasicNArgCommand(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ CompileEnv *envPtr);
+
+static Tcl_NRPostProc FreeER;
+
+/*
+ * The lists of subcommands and options for the [namespace ensemble] command.
+ */
+
+static const char *const ensembleSubcommands[] = {
+ "configure", "create", "exists", NULL
+};
+enum EnsSubcmds {
+ ENS_CONFIG, ENS_CREATE, ENS_EXISTS
+};
+
+static const char *const ensembleCreateOptions[] = {
+ "-command", "-map", "-parameters", "-prefixes", "-subcommands",
+ "-unknown", NULL
+};
+enum EnsCreateOpts {
+ CRT_CMD, CRT_MAP, CRT_PARAM, CRT_PREFIX, CRT_SUBCMDS, CRT_UNKNOWN
+};
+
+static const char *const ensembleConfigOptions[] = {
+ "-map", "-namespace", "-parameters", "-prefixes", "-subcommands",
+ "-unknown", NULL
+};
+enum EnsConfigOpts {
+ CONF_MAP, CONF_NAMESPACE, CONF_PARAM, CONF_PREFIX, CONF_SUBCMDS,
+ CONF_UNKNOWN
+};
+
+/*
+ * This structure defines a Tcl object type that contains a reference to an
+ * ensemble subcommand (e.g. the "length" in [string length ab]). It is used
+ * to cache the mapping between the subcommand itself and the real command
+ * that implements it.
+ */
+
+static const Tcl_ObjType ensembleCmdType = {
+ "ensembleCommand", /* the type's name */
+ FreeEnsembleCmdRep, /* freeIntRepProc */
+ DupEnsembleCmdRep, /* dupIntRepProc */
+ NULL, /* updateStringProc */
+ NULL /* setFromAnyProc */
+};
+
+/*
+ * The internal rep for caching ensemble subcommand lookups and
+ * spell corrections.
+ */
+
+typedef struct {
+ int epoch; /* Used to confirm when the data in this
+ * really structure matches up with the
+ * ensemble. */
+ Command *token; /* Reference to the command for which this
+ * structure is a cache of the resolution. */
+ Tcl_Obj *fix; /* Corrected spelling, if needed. */
+ Tcl_HashEntry *hPtr; /* Direct link to entry in the subcommand
+ * hash table. */
+} EnsembleCmdRep;
+
+
+static inline Tcl_Obj *
+NewNsObj(
+ Tcl_Namespace *namespacePtr)
+{
+ register Namespace *nsPtr = (Namespace *) namespacePtr;
+
+ if (namespacePtr == TclGetGlobalNamespace(nsPtr->interp)) {
+ return Tcl_NewStringObj("::", 2);
+ } else {
+ return Tcl_NewStringObj(nsPtr->fullName, -1);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclNamespaceEnsembleCmd --
+ *
+ * Invoked to implement the "namespace ensemble" command that creates and
+ * manipulates ensembles built on top of namespaces. Handles the
+ * following syntax:
+ *
+ * namespace ensemble name ?dictionary?
+ *
+ * Results:
+ * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
+ *
+ * Side effects:
+ * Creates the ensemble for the namespace if one did not previously
+ * exist. Alternatively, alters the way that the ensemble's subcommand =>
+ * implementation prefix is configured.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclNamespaceEnsembleCmd(
+ ClientData dummy,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_Namespace *namespacePtr;
+ Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp), *cxtPtr,
+ *foundNsPtr, *altFoundNsPtr, *actualCxtPtr;
+ Tcl_Command token;
+ Tcl_DictSearch search;
+ Tcl_Obj *listObj;
+ const char *simpleName;
+ int index, done;
+
+ if (nsPtr == NULL || nsPtr->flags & NS_DYING) {
+ if (!Tcl_InterpDeleted(interp)) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "tried to manipulate ensemble of deleted namespace",
+ -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "DEAD", NULL);
+ }
+ return TCL_ERROR;
+ }
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[1], ensembleSubcommands,
+ "subcommand", 0, &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ switch ((enum EnsSubcmds) index) {
+ case ENS_CREATE: {
+ const char *name;
+ int len, allocatedMapFlag = 0;
+ /*
+ * Defaults
+ */
+ Tcl_Obj *subcmdObj = NULL;
+ Tcl_Obj *mapObj = NULL;
+ int permitPrefix = 1;
+ Tcl_Obj *unknownObj = NULL;
+ Tcl_Obj *paramObj = NULL;
+
+ /*
+ * Check that we've got option-value pairs... [Bug 1558654]
+ */
+
+ if (objc & 1) {
+ Tcl_WrongNumArgs(interp, 2, objv, "?option value ...?");
+ return TCL_ERROR;
+ }
+ objv += 2;
+ objc -= 2;
+
+ name = nsPtr->name;
+ cxtPtr = (Namespace *) nsPtr->parentPtr;
+
+ /*
+ * Parse the option list, applying type checks as we go. Note that we
+ * are not incrementing any reference counts in the objects at this
+ * stage, so the presence of an option multiple times won't cause any
+ * memory leaks.
+ */
+
+ for (; objc>1 ; objc-=2,objv+=2) {
+ if (Tcl_GetIndexFromObj(interp, objv[0], ensembleCreateOptions,
+ "option", 0, &index) != TCL_OK) {
+ if (allocatedMapFlag) {
+ Tcl_DecrRefCount(mapObj);
+ }
+ return TCL_ERROR;
+ }
+ switch ((enum EnsCreateOpts) index) {
+ case CRT_CMD:
+ name = TclGetString(objv[1]);
+ cxtPtr = nsPtr;
+ continue;
+ case CRT_SUBCMDS:
+ if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
+ if (allocatedMapFlag) {
+ Tcl_DecrRefCount(mapObj);
+ }
+ return TCL_ERROR;
+ }
+ subcmdObj = (len > 0 ? objv[1] : NULL);
+ continue;
+ case CRT_PARAM:
+ if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
+ if (allocatedMapFlag) {
+ Tcl_DecrRefCount(mapObj);
+ }
+ return TCL_ERROR;
+ }
+ paramObj = (len > 0 ? objv[1] : NULL);
+ continue;
+ case CRT_MAP: {
+ Tcl_Obj *patchedDict = NULL, *subcmdWordsObj;
+
+ /*
+ * Verify that the map is sensible.
+ */
+
+ if (Tcl_DictObjFirst(interp, objv[1], &search,
+ &subcmdWordsObj, &listObj, &done) != TCL_OK) {
+ if (allocatedMapFlag) {
+ Tcl_DecrRefCount(mapObj);
+ }
+ return TCL_ERROR;
+ }
+ if (done) {
+ mapObj = NULL;
+ continue;
+ }
+ do {
+ Tcl_Obj **listv;
+ const char *cmd;
+
+ if (TclListObjGetElements(interp, listObj, &len,
+ &listv) != TCL_OK) {
+ Tcl_DictObjDone(&search);
+ if (patchedDict) {
+ Tcl_DecrRefCount(patchedDict);
+ }
+ if (allocatedMapFlag) {
+ Tcl_DecrRefCount(mapObj);
+ }
+ return TCL_ERROR;
+ }
+ if (len < 1) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "ensemble subcommand implementations "
+ "must be non-empty lists", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE",
+ "EMPTY_TARGET", NULL);
+ Tcl_DictObjDone(&search);
+ if (patchedDict) {
+ Tcl_DecrRefCount(patchedDict);
+ }
+ if (allocatedMapFlag) {
+ Tcl_DecrRefCount(mapObj);
+ }
+ return TCL_ERROR;
+ }
+ cmd = TclGetString(listv[0]);
+ if (!(cmd[0] == ':' && cmd[1] == ':')) {
+ Tcl_Obj *newList = Tcl_NewListObj(len, listv);
+ Tcl_Obj *newCmd = NewNsObj((Tcl_Namespace *) nsPtr);
+
+ if (nsPtr->parentPtr) {
+ Tcl_AppendStringsToObj(newCmd, "::", NULL);
+ }
+ Tcl_AppendObjToObj(newCmd, listv[0]);
+ Tcl_ListObjReplace(NULL, newList, 0, 1, 1, &newCmd);
+ if (patchedDict == NULL) {
+ patchedDict = Tcl_DuplicateObj(objv[1]);
+ }
+ Tcl_DictObjPut(NULL, patchedDict, subcmdWordsObj,
+ newList);
+ }
+ Tcl_DictObjNext(&search, &subcmdWordsObj,&listObj, &done);
+ } while (!done);
+
+ if (allocatedMapFlag) {
+ Tcl_DecrRefCount(mapObj);
+ }
+ mapObj = (patchedDict ? patchedDict : objv[1]);
+ if (patchedDict) {
+ allocatedMapFlag = 1;
+ }
+ continue;
+ }
+ case CRT_PREFIX:
+ if (Tcl_GetBooleanFromObj(interp, objv[1],
+ &permitPrefix) != TCL_OK) {
+ if (allocatedMapFlag) {
+ Tcl_DecrRefCount(mapObj);
+ }
+ return TCL_ERROR;
+ }
+ continue;
+ case CRT_UNKNOWN:
+ if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
+ if (allocatedMapFlag) {
+ Tcl_DecrRefCount(mapObj);
+ }
+ return TCL_ERROR;
+ }
+ unknownObj = (len > 0 ? objv[1] : NULL);
+ continue;
+ }
+ }
+
+ TclGetNamespaceForQualName(interp, name, cxtPtr,
+ TCL_CREATE_NS_IF_UNKNOWN, &foundNsPtr, &altFoundNsPtr, &actualCxtPtr,
+ &simpleName);
+
+ /*
+ * Create the ensemble. Note that this might delete another ensemble
+ * linked to the same namespace, so we must be careful. However, we
+ * should be OK because we only link the namespace into the list once
+ * we've created it (and after any deletions have occurred.)
+ */
+
+ token = TclCreateEnsembleInNs(interp, simpleName,
+ (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr,
+ (permitPrefix ? TCL_ENSEMBLE_PREFIX : 0));
+ Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj);
+ Tcl_SetEnsembleMappingDict(interp, token, mapObj);
+ Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj);
+ Tcl_SetEnsembleParameterList(interp, token, paramObj);
+
+ /*
+ * Tricky! Must ensure that the result is not shared (command delete
+ * traces could have corrupted the pristine object that we started
+ * with). [Snit test rename-1.5]
+ */
+
+ Tcl_ResetResult(interp);
+ Tcl_GetCommandFullName(interp, token, Tcl_GetObjResult(interp));
+ return TCL_OK;
+ }
+
+ case ENS_EXISTS:
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "cmdname");
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(
+ Tcl_FindEnsemble(interp, objv[2], 0) != NULL));
+ return TCL_OK;
+
+ case ENS_CONFIG:
+ if (objc < 3 || (objc != 4 && !(objc & 1))) {
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "cmdname ?-option value ...? ?arg ...?");
+ return TCL_ERROR;
+ }
+ token = Tcl_FindEnsemble(interp, objv[2], TCL_LEAVE_ERR_MSG);
+ if (token == NULL) {
+ return TCL_ERROR;
+ }
+
+ if (objc == 4) {
+ Tcl_Obj *resultObj = NULL; /* silence gcc 4 warning */
+
+ if (Tcl_GetIndexFromObj(interp, objv[3], ensembleConfigOptions,
+ "option", 0, &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch ((enum EnsConfigOpts) index) {
+ case CONF_SUBCMDS:
+ Tcl_GetEnsembleSubcommandList(NULL, token, &resultObj);
+ if (resultObj != NULL) {
+ Tcl_SetObjResult(interp, resultObj);
+ }
+ break;
+ case CONF_PARAM:
+ Tcl_GetEnsembleParameterList(NULL, token, &resultObj);
+ if (resultObj != NULL) {
+ Tcl_SetObjResult(interp, resultObj);
+ }
+ break;
+ case CONF_MAP:
+ Tcl_GetEnsembleMappingDict(NULL, token, &resultObj);
+ if (resultObj != NULL) {
+ Tcl_SetObjResult(interp, resultObj);
+ }
+ break;
+ case CONF_NAMESPACE:
+ namespacePtr = NULL; /* silence gcc 4 warning */
+ Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr);
+ Tcl_SetObjResult(interp, NewNsObj(namespacePtr));
+ break;
+ case CONF_PREFIX: {
+ int flags = 0; /* silence gcc 4 warning */
+
+ Tcl_GetEnsembleFlags(NULL, token, &flags);
+ Tcl_SetObjResult(interp,
+ Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX));
+ break;
+ }
+ case CONF_UNKNOWN:
+ Tcl_GetEnsembleUnknownHandler(NULL, token, &resultObj);
+ if (resultObj != NULL) {
+ Tcl_SetObjResult(interp, resultObj);
+ }
+ break;
+ }
+ } else if (objc == 3) {
+ /*
+ * Produce list of all information.
+ */
+
+ Tcl_Obj *resultObj, *tmpObj = NULL; /* silence gcc 4 warning */
+ int flags = 0; /* silence gcc 4 warning */
+
+ TclNewObj(resultObj);
+
+ /* -map option */
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ Tcl_NewStringObj(ensembleConfigOptions[CONF_MAP], -1));
+ Tcl_GetEnsembleMappingDict(NULL, token, &tmpObj);
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ (tmpObj != NULL) ? tmpObj : Tcl_NewObj());
+
+ /* -namespace option */
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ Tcl_NewStringObj(ensembleConfigOptions[CONF_NAMESPACE],
+ -1));
+ namespacePtr = NULL; /* silence gcc 4 warning */
+ Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr);
+ Tcl_ListObjAppendElement(NULL, resultObj, NewNsObj(namespacePtr));
+
+ /* -parameters option */
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ Tcl_NewStringObj(ensembleConfigOptions[CONF_PARAM], -1));
+ Tcl_GetEnsembleParameterList(NULL, token, &tmpObj);
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ (tmpObj != NULL) ? tmpObj : Tcl_NewObj());
+
+ /* -prefix option */
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ Tcl_NewStringObj(ensembleConfigOptions[CONF_PREFIX], -1));
+ Tcl_GetEnsembleFlags(NULL, token, &flags);
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX));
+
+ /* -subcommands option */
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ Tcl_NewStringObj(ensembleConfigOptions[CONF_SUBCMDS],-1));
+ Tcl_GetEnsembleSubcommandList(NULL, token, &tmpObj);
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ (tmpObj != NULL) ? tmpObj : Tcl_NewObj());
+
+ /* -unknown option */
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ Tcl_NewStringObj(ensembleConfigOptions[CONF_UNKNOWN],-1));
+ Tcl_GetEnsembleUnknownHandler(NULL, token, &tmpObj);
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ (tmpObj != NULL) ? tmpObj : Tcl_NewObj());
+
+ Tcl_SetObjResult(interp, resultObj);
+ } else {
+ int len, allocatedMapFlag = 0;
+ Tcl_Obj *subcmdObj = NULL, *mapObj = NULL, *paramObj = NULL,
+ *unknownObj = NULL; /* Defaults, silence gcc 4 warnings */
+ int permitPrefix, flags = 0; /* silence gcc 4 warning */
+
+ Tcl_GetEnsembleSubcommandList(NULL, token, &subcmdObj);
+ Tcl_GetEnsembleMappingDict(NULL, token, &mapObj);
+ Tcl_GetEnsembleParameterList(NULL, token, &paramObj);
+ Tcl_GetEnsembleUnknownHandler(NULL, token, &unknownObj);
+ Tcl_GetEnsembleFlags(NULL, token, &flags);
+ permitPrefix = (flags & TCL_ENSEMBLE_PREFIX) != 0;
+
+ objv += 3;
+ objc -= 3;
+
+ /*
+ * Parse the option list, applying type checks as we go. Note that
+ * we are not incrementing any reference counts in the objects at
+ * this stage, so the presence of an option multiple times won't
+ * cause any memory leaks.
+ */
+
+ for (; objc>0 ; objc-=2,objv+=2) {
+ if (Tcl_GetIndexFromObj(interp, objv[0],ensembleConfigOptions,
+ "option", 0, &index) != TCL_OK) {
+ freeMapAndError:
+ if (allocatedMapFlag) {
+ Tcl_DecrRefCount(mapObj);
+ }
+ return TCL_ERROR;
+ }
+ switch ((enum EnsConfigOpts) index) {
+ case CONF_SUBCMDS:
+ if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
+ goto freeMapAndError;
+ }
+ subcmdObj = (len > 0 ? objv[1] : NULL);
+ continue;
+ case CONF_PARAM:
+ if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
+ goto freeMapAndError;
+ }
+ paramObj = (len > 0 ? objv[1] : NULL);
+ continue;
+ case CONF_MAP: {
+ Tcl_Obj *patchedDict = NULL, *subcmdWordsObj, **listv;
+ const char *cmd;
+
+ /*
+ * Verify that the map is sensible.
+ */
+
+ if (Tcl_DictObjFirst(interp, objv[1], &search,
+ &subcmdWordsObj, &listObj, &done) != TCL_OK) {
+ goto freeMapAndError;
+ }
+ if (done) {
+ mapObj = NULL;
+ continue;
+ }
+ do {
+ if (TclListObjGetElements(interp, listObj, &len,
+ &listv) != TCL_OK) {
+ Tcl_DictObjDone(&search);
+ if (patchedDict) {
+ Tcl_DecrRefCount(patchedDict);
+ }
+ goto freeMapAndError;
+ }
+ if (len < 1) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "ensemble subcommand implementations "
+ "must be non-empty lists", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE",
+ "EMPTY_TARGET", NULL);
+ Tcl_DictObjDone(&search);
+ if (patchedDict) {
+ Tcl_DecrRefCount(patchedDict);
+ }
+ goto freeMapAndError;
+ }
+ cmd = TclGetString(listv[0]);
+ if (!(cmd[0] == ':' && cmd[1] == ':')) {
+ Tcl_Obj *newList = Tcl_DuplicateObj(listObj);
+ Tcl_Obj *newCmd = NewNsObj((Tcl_Namespace*)nsPtr);
+
+ if (nsPtr->parentPtr) {
+ Tcl_AppendStringsToObj(newCmd, "::", NULL);
+ }
+ Tcl_AppendObjToObj(newCmd, listv[0]);
+ Tcl_ListObjReplace(NULL, newList, 0,1, 1,&newCmd);
+ if (patchedDict == NULL) {
+ patchedDict = Tcl_DuplicateObj(objv[1]);
+ }
+ Tcl_DictObjPut(NULL, patchedDict, subcmdWordsObj,
+ newList);
+ }
+ Tcl_DictObjNext(&search, &subcmdWordsObj, &listObj,
+ &done);
+ } while (!done);
+ if (allocatedMapFlag) {
+ Tcl_DecrRefCount(mapObj);
+ }
+ mapObj = (patchedDict ? patchedDict : objv[1]);
+ if (patchedDict) {
+ allocatedMapFlag = 1;
+ }
+ continue;
+ }
+ case CONF_NAMESPACE:
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "option -namespace is read-only", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "READ_ONLY",
+ NULL);
+ goto freeMapAndError;
+ case CONF_PREFIX:
+ if (Tcl_GetBooleanFromObj(interp, objv[1],
+ &permitPrefix) != TCL_OK) {
+ goto freeMapAndError;
+ }
+ continue;
+ case CONF_UNKNOWN:
+ if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
+ goto freeMapAndError;
+ }
+ unknownObj = (len > 0 ? objv[1] : NULL);
+ continue;
+ }
+ }
+
+ /*
+ * Update the namespace now that we've finished the parsing stage.
+ */
+
+ flags = (permitPrefix ? flags|TCL_ENSEMBLE_PREFIX
+ : flags&~TCL_ENSEMBLE_PREFIX);
+ Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj);
+ Tcl_SetEnsembleMappingDict(interp, token, mapObj);
+ Tcl_SetEnsembleParameterList(interp, token, paramObj);
+ Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj);
+ Tcl_SetEnsembleFlags(interp, token, flags);
+ }
+ return TCL_OK;
+
+ default:
+ Tcl_Panic("unexpected ensemble command");
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCreateEnsembleInNs --
+ *
+ * Like Tcl_CreateEnsemble, but additionally accepts as an argument the
+ * name of the namespace to create the command in.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Command
+TclCreateEnsembleInNs(
+ Tcl_Interp *interp,
+
+ const char *name, /* Simple name of command to create (no */
+ /* namespace components). */
+ Tcl_Namespace /* Name of namespace to create the command in. */
+ *nameNsPtr,
+ Tcl_Namespace
+ *ensembleNsPtr, /* Name of the namespace for the ensemble. */
+ int flags
+ )
+{
+ Namespace *nsPtr = (Namespace *) ensembleNsPtr;
+ EnsembleConfig *ensemblePtr;
+ Tcl_Command token;
+
+ ensemblePtr = ckalloc(sizeof(EnsembleConfig));
+ token = TclNRCreateCommandInNs(interp, name,
+ (Tcl_Namespace *) nameNsPtr, NsEnsembleImplementationCmd,
+ NsEnsembleImplementationCmdNR, ensemblePtr, DeleteEnsembleConfig);
+ if (token == NULL) {
+ ckfree(ensemblePtr);
+ return NULL;
+ }
+
+ ensemblePtr->nsPtr = nsPtr;
+ ensemblePtr->epoch = 0;
+ Tcl_InitHashTable(&ensemblePtr->subcommandTable, TCL_STRING_KEYS);
+ ensemblePtr->subcommandArrayPtr = NULL;
+ ensemblePtr->subcmdList = NULL;
+ ensemblePtr->subcommandDict = NULL;
+ ensemblePtr->flags = flags;
+ ensemblePtr->numParameters = 0;
+ ensemblePtr->parameterList = NULL;
+ ensemblePtr->unknownHandler = NULL;
+ ensemblePtr->token = token;
+ ensemblePtr->next = (EnsembleConfig *) nsPtr->ensembles;
+ nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr;
+
+ /*
+ * Trigger an eventual recomputation of the ensemble command set. Note
+ * that this is slightly tricky, as it means that we are not actually
+ * counting the number of namespace export actions, but it is the simplest
+ * way to go!
+ */
+
+ nsPtr->exportLookupEpoch++;
+
+ if (flags & ENSEMBLE_COMPILE) {
+ ((Command *) ensemblePtr->token)->compileProc = TclCompileEnsemble;
+ }
+
+ return ensemblePtr->token;
+
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_CreateEnsemble
+ *
+ * Create a simple ensemble attached to the given namespace.
+ *
+ * Deprecated by TclCreateEnsembleInNs.
+ *
+ * Value
+ *
+ * The token for the command created.
+ *
+ * Effect
+ * The ensemble is created and marked for compilation.
+ *
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Command
+Tcl_CreateEnsemble(
+ Tcl_Interp *interp,
+ const char *name,
+ Tcl_Namespace *namespacePtr,
+ int flags)
+{
+ Tcl_Obj *nameObj = NULL;
+ Namespace *nsPtr = (Namespace *)namespacePtr, *foundNsPtr, *altNsPtr,
+ *actualNsPtr;
+ const char * simpleName;
+
+ if (nsPtr == NULL) {
+ nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
+ }
+
+ TclGetNamespaceForQualName(interp, name, nsPtr, 0,
+ &foundNsPtr, &altNsPtr, &actualNsPtr, &simpleName);
+ if (nameObj != NULL) {
+ TclDecrRefCount(nameObj);
+ }
+ return TclCreateEnsembleInNs(interp, simpleName,
+ (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr, flags);
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SetEnsembleSubcommandList --
+ *
+ * Set the subcommand list for a particular ensemble.
+ *
+ * Results:
+ * Tcl result code (error if command token does not indicate an ensemble
+ * or the subcommand list - if non-NULL - is not a list).
+ *
+ * Side effects:
+ * The ensemble is updated and marked for recompilation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_SetEnsembleSubcommandList(
+ Tcl_Interp *interp,
+ Tcl_Command token,
+ Tcl_Obj *subcmdList)
+{
+ Command *cmdPtr = (Command *) token;
+ EnsembleConfig *ensemblePtr;
+ Tcl_Obj *oldList;
+
+ if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "command is not an ensemble", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
+ return TCL_ERROR;
+ }
+ if (subcmdList != NULL) {
+ int length;
+
+ if (TclListObjLength(interp, subcmdList, &length) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (length < 1) {
+ subcmdList = NULL;
+ }
+ }
+
+ ensemblePtr = cmdPtr->objClientData;
+ oldList = ensemblePtr->subcmdList;
+ ensemblePtr->subcmdList = subcmdList;
+ if (subcmdList != NULL) {
+ Tcl_IncrRefCount(subcmdList);
+ }
+ if (oldList != NULL) {
+ TclDecrRefCount(oldList);
+ }
+
+ /*
+ * Trigger an eventual recomputation of the ensemble command set. Note
+ * that this is slightly tricky, as it means that we are not actually
+ * counting the number of namespace export actions, but it is the simplest
+ * way to go!
+ */
+
+ ensemblePtr->nsPtr->exportLookupEpoch++;
+
+ /*
+ * Special hack to make compiling of [info exists] work when the
+ * dictionary is modified.
+ */
+
+ if (cmdPtr->compileProc != NULL) {
+ ((Interp *) interp)->compileEpoch++;
+ }
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SetEnsembleParameterList --
+ *
+ * Set the parameter list for a particular ensemble.
+ *
+ * Results:
+ * Tcl result code (error if command token does not indicate an ensemble
+ * or the parameter list - if non-NULL - is not a list).
+ *
+ * Side effects:
+ * The ensemble is updated and marked for recompilation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_SetEnsembleParameterList(
+ Tcl_Interp *interp,
+ Tcl_Command token,
+ Tcl_Obj *paramList)
+{
+ Command *cmdPtr = (Command *) token;
+ EnsembleConfig *ensemblePtr;
+ Tcl_Obj *oldList;
+ int length;
+
+ if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "command is not an ensemble", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
+ return TCL_ERROR;
+ }
+ if (paramList == NULL) {
+ length = 0;
+ } else {
+ if (TclListObjLength(interp, paramList, &length) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (length < 1) {
+ paramList = NULL;
+ }
+ }
+
+ ensemblePtr = cmdPtr->objClientData;
+ oldList = ensemblePtr->parameterList;
+ ensemblePtr->parameterList = paramList;
+ if (paramList != NULL) {
+ Tcl_IncrRefCount(paramList);
+ }
+ if (oldList != NULL) {
+ TclDecrRefCount(oldList);
+ }
+ ensemblePtr->numParameters = length;
+
+ /*
+ * Trigger an eventual recomputation of the ensemble command set. Note
+ * that this is slightly tricky, as it means that we are not actually
+ * counting the number of namespace export actions, but it is the simplest
+ * way to go!
+ */
+
+ ensemblePtr->nsPtr->exportLookupEpoch++;
+
+ /*
+ * Special hack to make compiling of [info exists] work when the
+ * dictionary is modified.
+ */
+
+ if (cmdPtr->compileProc != NULL) {
+ ((Interp *) interp)->compileEpoch++;
+ }
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SetEnsembleMappingDict --
+ *
+ * Set the mapping dictionary for a particular ensemble.
+ *
+ * Results:
+ * Tcl result code (error if command token does not indicate an ensemble
+ * or the mapping - if non-NULL - is not a dict).
+ *
+ * Side effects:
+ * The ensemble is updated and marked for recompilation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_SetEnsembleMappingDict(
+ Tcl_Interp *interp,
+ Tcl_Command token,
+ Tcl_Obj *mapDict)
+{
+ Command *cmdPtr = (Command *) token;
+ EnsembleConfig *ensemblePtr;
+ Tcl_Obj *oldDict;
+
+ if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "command is not an ensemble", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
+ return TCL_ERROR;
+ }
+ if (mapDict != NULL) {
+ int size, done;
+ Tcl_DictSearch search;
+ Tcl_Obj *valuePtr;
+
+ if (Tcl_DictObjSize(interp, mapDict, &size) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ for (Tcl_DictObjFirst(NULL, mapDict, &search, NULL, &valuePtr, &done);
+ !done; Tcl_DictObjNext(&search, NULL, &valuePtr, &done)) {
+ Tcl_Obj *cmdObjPtr;
+ const char *bytes;
+
+ if (Tcl_ListObjIndex(interp, valuePtr, 0, &cmdObjPtr) != TCL_OK) {
+ Tcl_DictObjDone(&search);
+ return TCL_ERROR;
+ }
+ bytes = TclGetString(cmdObjPtr);
+ if (bytes[0] != ':' || bytes[1] != ':') {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "ensemble target is not a fully-qualified command",
+ -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE",
+ "UNQUALIFIED_TARGET", NULL);
+ Tcl_DictObjDone(&search);
+ return TCL_ERROR;
+ }
+ }
+
+ if (size < 1) {
+ mapDict = NULL;
+ }
+ }
+
+ ensemblePtr = cmdPtr->objClientData;
+ oldDict = ensemblePtr->subcommandDict;
+ ensemblePtr->subcommandDict = mapDict;
+ if (mapDict != NULL) {
+ Tcl_IncrRefCount(mapDict);
+ }
+ if (oldDict != NULL) {
+ TclDecrRefCount(oldDict);
+ }
+
+ /*
+ * Trigger an eventual recomputation of the ensemble command set. Note
+ * that this is slightly tricky, as it means that we are not actually
+ * counting the number of namespace export actions, but it is the simplest
+ * way to go!
+ */
+
+ ensemblePtr->nsPtr->exportLookupEpoch++;
+
+ /*
+ * Special hack to make compiling of [info exists] work when the
+ * dictionary is modified.
+ */
+
+ if (cmdPtr->compileProc != NULL) {
+ ((Interp *) interp)->compileEpoch++;
+ }
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SetEnsembleUnknownHandler --
+ *
+ * Set the unknown handler for a particular ensemble.
+ *
+ * Results:
+ * Tcl result code (error if command token does not indicate an ensemble
+ * or the unknown handler - if non-NULL - is not a list).
+ *
+ * Side effects:
+ * The ensemble is updated and marked for recompilation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_SetEnsembleUnknownHandler(
+ Tcl_Interp *interp,
+ Tcl_Command token,
+ Tcl_Obj *unknownList)
+{
+ Command *cmdPtr = (Command *) token;
+ EnsembleConfig *ensemblePtr;
+ Tcl_Obj *oldList;
+
+ if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "command is not an ensemble", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
+ return TCL_ERROR;
+ }
+ if (unknownList != NULL) {
+ int length;
+
+ if (TclListObjLength(interp, unknownList, &length) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (length < 1) {
+ unknownList = NULL;
+ }
+ }
+
+ ensemblePtr = cmdPtr->objClientData;
+ oldList = ensemblePtr->unknownHandler;
+ ensemblePtr->unknownHandler = unknownList;
+ if (unknownList != NULL) {
+ Tcl_IncrRefCount(unknownList);
+ }
+ if (oldList != NULL) {
+ TclDecrRefCount(oldList);
+ }
+
+ /*
+ * Trigger an eventual recomputation of the ensemble command set. Note
+ * that this is slightly tricky, as it means that we are not actually
+ * counting the number of namespace export actions, but it is the simplest
+ * way to go!
+ */
+
+ ensemblePtr->nsPtr->exportLookupEpoch++;
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SetEnsembleFlags --
+ *
+ * Set the flags for a particular ensemble.
+ *
+ * Results:
+ * Tcl result code (error if command token does not indicate an
+ * ensemble).
+ *
+ * Side effects:
+ * The ensemble is updated and marked for recompilation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_SetEnsembleFlags(
+ Tcl_Interp *interp,
+ Tcl_Command token,
+ int flags)
+{
+ Command *cmdPtr = (Command *) token;
+ EnsembleConfig *ensemblePtr;
+ int wasCompiled;
+
+ if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "command is not an ensemble", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
+ return TCL_ERROR;
+ }
+
+ ensemblePtr = cmdPtr->objClientData;
+ wasCompiled = ensemblePtr->flags & ENSEMBLE_COMPILE;
+
+ /*
+ * This API refuses to set the ENSEMBLE_DEAD flag...
+ */
+
+ ensemblePtr->flags &= ENSEMBLE_DEAD;
+ ensemblePtr->flags |= flags & ~ENSEMBLE_DEAD;
+
+ /*
+ * Trigger an eventual recomputation of the ensemble command set. Note
+ * that this is slightly tricky, as it means that we are not actually
+ * counting the number of namespace export actions, but it is the simplest
+ * way to go!
+ */
+
+ ensemblePtr->nsPtr->exportLookupEpoch++;
+
+ /*
+ * If the ENSEMBLE_COMPILE flag status was changed, install or remove the
+ * compiler function and bump the interpreter's compilation epoch so that
+ * bytecode gets regenerated.
+ */
+
+ if (flags & ENSEMBLE_COMPILE) {
+ if (!wasCompiled) {
+ ((Command*) ensemblePtr->token)->compileProc = TclCompileEnsemble;
+ ((Interp *) interp)->compileEpoch++;
+ }
+ } else {
+ if (wasCompiled) {
+ ((Command *) ensemblePtr->token)->compileProc = NULL;
+ ((Interp *) interp)->compileEpoch++;
+ }
+ }
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetEnsembleSubcommandList --
+ *
+ * Get the list of subcommands associated with a particular ensemble.
+ *
+ * Results:
+ * Tcl result code (error if command token does not indicate an
+ * ensemble). The list of subcommands is returned by updating the
+ * variable pointed to by the last parameter (NULL if this is to be
+ * derived from the mapping dictionary or the associated namespace's
+ * exported commands).
+ *
+ * Side effects:
+ * None
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_GetEnsembleSubcommandList(
+ Tcl_Interp *interp,
+ Tcl_Command token,
+ Tcl_Obj **subcmdListPtr)
+{
+ Command *cmdPtr = (Command *) token;
+ EnsembleConfig *ensemblePtr;
+
+ if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "command is not an ensemble", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
+ }
+ return TCL_ERROR;
+ }
+
+ ensemblePtr = cmdPtr->objClientData;
+ *subcmdListPtr = ensemblePtr->subcmdList;
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetEnsembleParameterList --
+ *
+ * Get the list of parameters associated with a particular ensemble.
+ *
+ * Results:
+ * Tcl result code (error if command token does not indicate an
+ * ensemble). The list of parameters is returned by updating the
+ * variable pointed to by the last parameter (NULL if there are
+ * no parameters).
+ *
+ * Side effects:
+ * None
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_GetEnsembleParameterList(
+ Tcl_Interp *interp,
+ Tcl_Command token,
+ Tcl_Obj **paramListPtr)
+{
+ Command *cmdPtr = (Command *) token;
+ EnsembleConfig *ensemblePtr;
+
+ if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "command is not an ensemble", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
+ }
+ return TCL_ERROR;
+ }
+
+ ensemblePtr = cmdPtr->objClientData;
+ *paramListPtr = ensemblePtr->parameterList;
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetEnsembleMappingDict --
+ *
+ * Get the command mapping dictionary associated with a particular
+ * ensemble.
+ *
+ * Results:
+ * Tcl result code (error if command token does not indicate an
+ * ensemble). The mapping dict is returned by updating the variable
+ * pointed to by the last parameter (NULL if none is installed).
+ *
+ * Side effects:
+ * None
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_GetEnsembleMappingDict(
+ Tcl_Interp *interp,
+ Tcl_Command token,
+ Tcl_Obj **mapDictPtr)
+{
+ Command *cmdPtr = (Command *) token;
+ EnsembleConfig *ensemblePtr;
+
+ if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "command is not an ensemble", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
+ }
+ return TCL_ERROR;
+ }
+
+ ensemblePtr = cmdPtr->objClientData;
+ *mapDictPtr = ensemblePtr->subcommandDict;
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetEnsembleUnknownHandler --
+ *
+ * Get the unknown handler associated with a particular ensemble.
+ *
+ * Results:
+ * Tcl result code (error if command token does not indicate an
+ * ensemble). The unknown handler is returned by updating the variable
+ * pointed to by the last parameter (NULL if no handler is installed).
+ *
+ * Side effects:
+ * None
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_GetEnsembleUnknownHandler(
+ Tcl_Interp *interp,
+ Tcl_Command token,
+ Tcl_Obj **unknownListPtr)
+{
+ Command *cmdPtr = (Command *) token;
+ EnsembleConfig *ensemblePtr;
+
+ if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "command is not an ensemble", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
+ }
+ return TCL_ERROR;
+ }
+
+ ensemblePtr = cmdPtr->objClientData;
+ *unknownListPtr = ensemblePtr->unknownHandler;
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetEnsembleFlags --
+ *
+ * Get the flags for a particular ensemble.
+ *
+ * Results:
+ * Tcl result code (error if command token does not indicate an
+ * ensemble). The flags are returned by updating the variable pointed to
+ * by the last parameter.
+ *
+ * Side effects:
+ * None
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_GetEnsembleFlags(
+ Tcl_Interp *interp,
+ Tcl_Command token,
+ int *flagsPtr)
+{
+ Command *cmdPtr = (Command *) token;
+ EnsembleConfig *ensemblePtr;
+
+ if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "command is not an ensemble", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
+ }
+ return TCL_ERROR;
+ }
+
+ ensemblePtr = cmdPtr->objClientData;
+ *flagsPtr = ensemblePtr->flags;
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetEnsembleNamespace --
+ *
+ * Get the namespace associated with a particular ensemble.
+ *
+ * Results:
+ * Tcl result code (error if command token does not indicate an
+ * ensemble). Namespace is returned by updating the variable pointed to
+ * by the last parameter.
+ *
+ * Side effects:
+ * None
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_GetEnsembleNamespace(
+ Tcl_Interp *interp,
+ Tcl_Command token,
+ Tcl_Namespace **namespacePtrPtr)
+{
+ Command *cmdPtr = (Command *) token;
+ EnsembleConfig *ensemblePtr;
+
+ if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "command is not an ensemble", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
+ }
+ return TCL_ERROR;
+ }
+
+ ensemblePtr = cmdPtr->objClientData;
+ *namespacePtrPtr = (Tcl_Namespace *) ensemblePtr->nsPtr;
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FindEnsemble --
+ *
+ * Given a command name, get the ensemble token for it, allowing for
+ * [namespace import]s. [Bug 1017022]
+ *
+ * Results:
+ * The token for the ensemble command with the given name, or NULL if the
+ * command either does not exist or is not an ensemble (when an error
+ * message will be written into the interp if thats non-NULL).
+ *
+ * Side effects:
+ * None
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Command
+Tcl_FindEnsemble(
+ Tcl_Interp *interp, /* Where to do the lookup, and where to write
+ * the errors if TCL_LEAVE_ERR_MSG is set in
+ * the flags. */
+ Tcl_Obj *cmdNameObj, /* Name of command to look up. */
+ int flags) /* Either 0 or TCL_LEAVE_ERR_MSG; other flags
+ * are probably not useful. */
+{
+ Command *cmdPtr;
+
+ cmdPtr = (Command *)
+ Tcl_FindCommand(interp, TclGetString(cmdNameObj), NULL, flags);
+ if (cmdPtr == NULL) {
+ return NULL;
+ }
+
+ if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ /*
+ * Reuse existing infrastructure for following import link chains
+ * rather than duplicating it.
+ */
+
+ cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
+
+ if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd){
+ if (flags & TCL_LEAVE_ERR_MSG) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" is not an ensemble command",
+ TclGetString(cmdNameObj)));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENSEMBLE",
+ TclGetString(cmdNameObj), NULL);
+ }
+ return NULL;
+ }
+ }
+
+ return (Tcl_Command) cmdPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_IsEnsemble --
+ *
+ * Simple test for ensemble-hood that takes into account imported
+ * ensemble commands as well.
+ *
+ * Results:
+ * Boolean value
+ *
+ * Side effects:
+ * None
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_IsEnsemble(
+ Tcl_Command token)
+{
+ Command *cmdPtr = (Command *) token;
+
+ if (cmdPtr->objProc == NsEnsembleImplementationCmd) {
+ return 1;
+ }
+ cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
+ if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ return 0;
+ }
+ return 1;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclMakeEnsemble --
+ *
+ * Create an ensemble from a table of implementation commands. The
+ * ensemble will be subject to (limited) compilation if any of the
+ * implementation commands are compilable.
+ *
+ * The 'name' parameter may be a single command name or a list if
+ * creating an ensemble subcommand (see the binary implementation).
+ *
+ * Currently, the TCL_ENSEMBLE_PREFIX ensemble flag is only used on
+ * top-level ensemble commands.
+ *
+ * Results:
+ * Handle for the new ensemble, or NULL on failure.
+ *
+ * Side effects:
+ * May advance the bytecode compilation epoch.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Command
+TclMakeEnsemble(
+ Tcl_Interp *interp,
+ const char *name, /* The ensemble name (as explained above) */
+ const EnsembleImplMap map[]) /* The subcommands to create */
+{
+ Tcl_Command ensemble;
+ Tcl_Namespace *ns;
+ Tcl_DString buf, hiddenBuf;
+ const char **nameParts = NULL;
+ const char *cmdName = NULL;
+ int i, nameCount = 0, ensembleFlags = 0, hiddenLen;
+
+ /*
+ * Construct the path for the ensemble namespace and create it.
+ */
+
+ Tcl_DStringInit(&buf);
+ Tcl_DStringInit(&hiddenBuf);
+ TclDStringAppendLiteral(&hiddenBuf, "tcl:");
+ Tcl_DStringAppend(&hiddenBuf, name, -1);
+ TclDStringAppendLiteral(&hiddenBuf, ":");
+ hiddenLen = Tcl_DStringLength(&hiddenBuf);
+ if (name[0] == ':' && name[1] == ':') {
+ /*
+ * An absolute name, so use it directly.
+ */
+
+ cmdName = name;
+ Tcl_DStringAppend(&buf, name, -1);
+ ensembleFlags = TCL_ENSEMBLE_PREFIX;
+ } else {
+ /*
+ * Not an absolute name, so do munging of it. Note that this treats a
+ * multi-word list differently to a single word.
+ */
+
+ TclDStringAppendLiteral(&buf, "::tcl");
+
+ if (Tcl_SplitList(NULL, name, &nameCount, &nameParts) != TCL_OK) {
+ Tcl_Panic("invalid ensemble name '%s'", name);
+ }
+
+ for (i = 0; i < nameCount; ++i) {
+ TclDStringAppendLiteral(&buf, "::");
+ Tcl_DStringAppend(&buf, nameParts[i], -1);
+ }
+ }
+
+ ns = Tcl_FindNamespace(interp, Tcl_DStringValue(&buf), NULL,
+ TCL_CREATE_NS_IF_UNKNOWN);
+ if (!ns) {
+ Tcl_Panic("unable to find or create %s namespace!",
+ Tcl_DStringValue(&buf));
+ }
+
+ /*
+ * Create the named ensemble in the correct namespace
+ */
+
+ if (cmdName == NULL) {
+ if (nameCount == 1) {
+ ensembleFlags = TCL_ENSEMBLE_PREFIX;
+ cmdName = Tcl_DStringValue(&buf) + 5;
+ } else {
+ ns = ns->parentPtr;
+ cmdName = nameParts[nameCount - 1];
+ }
+ }
+
+ /*
+ * Switch on compilation always for core ensembles now that we can do
+ * nice bytecode things with them. Do it now. Waiting until later will
+ * just cause pointless epoch bumps.
+ */
+
+ ensembleFlags |= ENSEMBLE_COMPILE;
+ ensemble = Tcl_CreateEnsemble(interp, cmdName, ns, ensembleFlags);
+
+ /*
+ * Create the ensemble mapping dictionary and the ensemble command procs.
+ */
+
+ if (ensemble != NULL) {
+ Tcl_Obj *mapDict, *fromObj, *toObj;
+ Command *cmdPtr;
+
+ TclDStringAppendLiteral(&buf, "::");
+ TclNewObj(mapDict);
+ for (i=0 ; map[i].name != NULL ; i++) {
+ fromObj = Tcl_NewStringObj(map[i].name, -1);
+ TclNewStringObj(toObj, Tcl_DStringValue(&buf),
+ Tcl_DStringLength(&buf));
+ Tcl_AppendToObj(toObj, map[i].name, -1);
+ Tcl_DictObjPut(NULL, mapDict, fromObj, toObj);
+
+ if (map[i].proc || map[i].nreProc) {
+ /*
+ * If the command is unsafe, hide it when we're in a safe
+ * interpreter. The code to do this is really hokey! It also
+ * doesn't work properly yet; this function is always
+ * currently called before the safe-interp flag is set so the
+ * Tcl_IsSafe check fails.
+ */
+
+ if (map[i].unsafe && Tcl_IsSafe(interp)) {
+ cmdPtr = (Command *)
+ Tcl_NRCreateCommand(interp, "___tmp", map[i].proc,
+ map[i].nreProc, map[i].clientData, NULL);
+ Tcl_DStringSetLength(&hiddenBuf, hiddenLen);
+ if (Tcl_HideCommand(interp, "___tmp",
+ Tcl_DStringAppend(&hiddenBuf, map[i].name, -1))) {
+ Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp)));
+ }
+ } else {
+ /*
+ * Not hidden, so just create it. Yay!
+ */
+
+ cmdPtr = (Command *)
+ Tcl_NRCreateCommand(interp, TclGetString(toObj),
+ map[i].proc, map[i].nreProc, map[i].clientData,
+ NULL);
+ }
+ cmdPtr->compileProc = map[i].compileProc;
+ }
+ }
+ Tcl_SetEnsembleMappingDict(interp, ensemble, mapDict);
+ }
+
+ Tcl_DStringFree(&buf);
+ Tcl_DStringFree(&hiddenBuf);
+ if (nameParts != NULL) {
+ ckfree((char *) nameParts);
+ }
+ return ensemble;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * NsEnsembleImplementationCmd --
+ *
+ * Implements an ensemble of commands (being those exported by a
+ * namespace other than the global namespace) as a command with the same
+ * (short) name as the namespace in the parent namespace.
+ *
+ * Results:
+ * A standard Tcl result code. Will be TCL_ERROR if the command is not an
+ * unambiguous prefix of any command exported by the ensemble's
+ * namespace.
+ *
+ * Side effects:
+ * Depends on the command within the namespace that gets executed. If the
+ * ensemble itself returns TCL_ERROR, a descriptive error message will be
+ * placed in the interpreter's result.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+NsEnsembleImplementationCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ return Tcl_NRCallObjProc(interp, NsEnsembleImplementationCmdNR,
+ clientData, objc, objv);
+}
+
+static int
+NsEnsembleImplementationCmdNR(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ EnsembleConfig *ensemblePtr = clientData;
+ /* The ensemble itself. */
+ Tcl_Obj *prefixObj; /* An object containing the prefix words of
+ * the command that implements the
+ * subcommand. */
+ Tcl_HashEntry *hPtr; /* Used for efficient lookup of fully
+ * specified but not yet cached command
+ * names. */
+ int reparseCount = 0; /* Number of reparses. */
+ Tcl_Obj *errorObj; /* Used for building error messages. */
+ Tcl_Obj *subObj;
+ int subIdx;
+
+ /*
+ * Must recheck objc, since numParameters might have changed. Cf. test
+ * namespace-53.9.
+ */
+
+ restartEnsembleParse:
+ subIdx = 1 + ensemblePtr->numParameters;
+ if (objc < subIdx + 1) {
+ /*
+ * We don't have a subcommand argument. Make error message.
+ */
+
+ Tcl_DString buf; /* Message being built */
+
+ Tcl_DStringInit(&buf);
+ if (ensemblePtr->parameterList) {
+ Tcl_DStringAppend(&buf,
+ TclGetString(ensemblePtr->parameterList), -1);
+ TclDStringAppendLiteral(&buf, " ");
+ }
+ TclDStringAppendLiteral(&buf, "subcommand ?arg ...?");
+ Tcl_WrongNumArgs(interp, 1, objv, Tcl_DStringValue(&buf));
+ Tcl_DStringFree(&buf);
+
+ return TCL_ERROR;
+ }
+
+ if (ensemblePtr->nsPtr->flags & NS_DYING) {
+ /*
+ * Don't know how we got here, but make things give up quickly.
+ */
+
+ if (!Tcl_InterpDeleted(interp)) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "ensemble activated for deleted namespace", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "DEAD", NULL);
+ }
+ return TCL_ERROR;
+ }
+
+ /*
+ * Determine if the table of subcommands is right. If so, we can just look
+ * up in there and go straight to dispatch.
+ */
+
+ subObj = objv[subIdx];
+
+ if (ensemblePtr->epoch == ensemblePtr->nsPtr->exportLookupEpoch) {
+ /*
+ * Table of subcommands is still valid; therefore there might be a
+ * valid cache of discovered information which we can reuse. Do the
+ * check here, and if we're still valid, we can jump straight to the
+ * part where we do the invocation of the subcommand.
+ */
+
+ if (subObj->typePtr==&ensembleCmdType){
+ EnsembleCmdRep *ensembleCmd = subObj->internalRep.twoPtrValue.ptr1;
+
+ if (ensembleCmd->epoch == ensemblePtr->epoch &&
+ ensembleCmd->token == (Command *)ensemblePtr->token) {
+ prefixObj = Tcl_GetHashValue(ensembleCmd->hPtr);
+ Tcl_IncrRefCount(prefixObj);
+ if (ensembleCmd->fix) {
+ TclSpellFix(interp, objv, objc, subIdx, subObj, ensembleCmd->fix);
+ }
+ goto runResultingSubcommand;
+ }
+ }
+ } else {
+ BuildEnsembleConfig(ensemblePtr);
+ ensemblePtr->epoch = ensemblePtr->nsPtr->exportLookupEpoch;
+ }
+
+ /*
+ * Look in the hashtable for the subcommand name; this is the fastest way
+ * of all if there is no cache in operation.
+ */
+
+ hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable,
+ TclGetString(subObj));
+ if (hPtr != NULL) {
+
+ /*
+ * Cache for later in the subcommand object.
+ */
+
+ MakeCachedEnsembleCommand(subObj, ensemblePtr, hPtr, NULL);
+ } else if (!(ensemblePtr->flags & TCL_ENSEMBLE_PREFIX)) {
+ /*
+ * Could not map, no prefixing, go to unknown/error handling.
+ */
+
+ goto unknownOrAmbiguousSubcommand;
+ } else {
+ /*
+ * If we've not already confirmed the command with the hash as part of
+ * building our export table, we need to scan the sorted array for
+ * matches.
+ */
+
+ const char *subcmdName; /* Name of the subcommand, or unique prefix of
+ * it (will be an error for a non-unique
+ * prefix). */
+ char *fullName = NULL; /* Full name of the subcommand. */
+ int stringLength, i;
+ int tableLength = ensemblePtr->subcommandTable.numEntries;
+ Tcl_Obj *fix;
+
+ subcmdName = Tcl_GetStringFromObj(subObj, &stringLength);
+ for (i=0 ; i<tableLength ; i++) {
+ register int cmp = strncmp(subcmdName,
+ ensemblePtr->subcommandArrayPtr[i],
+ (unsigned) stringLength);
+
+ if (cmp == 0) {
+ if (fullName != NULL) {
+ /*
+ * Since there's never the exact-match case to worry about
+ * (hash search filters this), getting here indicates that
+ * our subcommand is an ambiguous prefix of (at least) two
+ * exported subcommands, which is an error case.
+ */
+
+ goto unknownOrAmbiguousSubcommand;
+ }
+ fullName = ensemblePtr->subcommandArrayPtr[i];
+ } else if (cmp < 0) {
+ /*
+ * Because we are searching a sorted table, we can now stop
+ * searching because we have gone past anything that could
+ * possibly match.
+ */
+
+ break;
+ }
+ }
+ if (fullName == NULL) {
+ /*
+ * The subcommand is not a prefix of anything, so bail out!
+ */
+
+ goto unknownOrAmbiguousSubcommand;
+ }
+ hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable, fullName);
+ if (hPtr == NULL) {
+ Tcl_Panic("full name %s not found in supposedly synchronized hash",
+ fullName);
+ }
+
+ /*
+ * Record the spelling correction for usage message.
+ */
+
+ fix = Tcl_NewStringObj(fullName, -1);
+
+ /*
+ * Cache for later in the subcommand object.
+ */
+
+ MakeCachedEnsembleCommand(subObj, ensemblePtr, hPtr, fix);
+ TclSpellFix(interp, objv, objc, subIdx, subObj, fix);
+ }
+
+ prefixObj = Tcl_GetHashValue(hPtr);
+ Tcl_IncrRefCount(prefixObj);
+ runResultingSubcommand:
+
+ /*
+ * Do the real work of execution of the subcommand by building an array of
+ * objects (note that this is potentially not the same length as the
+ * number of arguments to this ensemble command), populating it and then
+ * feeding it back through the main command-lookup engine. In theory, we
+ * could look up the command in the namespace ourselves, as we already
+ * have the namespace in which it is guaranteed to exist,
+ *
+ * ((Q: That's not true if the -map option is used, is it?))
+ *
+ * but we don't do that (the cacheing of the command object used should
+ * help with that.)
+ */
+
+ {
+ Tcl_Obj *copyPtr; /* The actual list of words to dispatch to.
+ * Will be freed by the dispatch engine. */
+ Tcl_Obj **copyObjv;
+ int copyObjc, prefixObjc;
+
+ Tcl_ListObjLength(NULL, prefixObj, &prefixObjc);
+
+ if (objc == 2) {
+ copyPtr = TclListObjCopy(NULL, prefixObj);
+ } else {
+ copyPtr = Tcl_NewListObj(objc - 2 + prefixObjc, NULL);
+ Tcl_ListObjAppendList(NULL, copyPtr, prefixObj);
+ Tcl_ListObjReplace(NULL, copyPtr, LIST_MAX, 0,
+ ensemblePtr->numParameters, objv + 1);
+ Tcl_ListObjReplace(NULL, copyPtr, LIST_MAX, 0,
+ objc - 2 - ensemblePtr->numParameters,
+ objv + 2 + ensemblePtr->numParameters);
+ }
+ Tcl_IncrRefCount(copyPtr);
+ TclNRAddCallback(interp, TclNRReleaseValues, copyPtr, NULL, NULL, NULL);
+ TclDecrRefCount(prefixObj);
+
+ /*
+ * Record what arguments the script sent in so that things like
+ * Tcl_WrongNumArgs can give the correct error message. Parameters
+ * count both as inserted and removed arguments.
+ */
+
+ if (TclInitRewriteEnsemble(interp, 2 + ensemblePtr->numParameters,
+ prefixObjc + ensemblePtr->numParameters, objv)) {
+ TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL,
+ NULL);
+ }
+
+ /*
+ * Hand off to the target command.
+ */
+
+ TclSkipTailcall(interp);
+ Tcl_ListObjGetElements(NULL, copyPtr, &copyObjc, &copyObjv);
+ ((Interp *)interp)->lookupNsPtr = ensemblePtr->nsPtr;
+ return TclNREvalObjv(interp, copyObjc, copyObjv, TCL_EVAL_INVOKE, NULL);
+ }
+
+ unknownOrAmbiguousSubcommand:
+ /*
+ * Have not been able to match the subcommand asked for with a real
+ * subcommand that we export. See whether a handler has been registered
+ * for dealing with this situation. Will only call (at most) once for any
+ * particular ensemble invocation.
+ */
+
+ if (ensemblePtr->unknownHandler != NULL && reparseCount++ < 1) {
+ switch (EnsembleUnknownCallback(interp, ensemblePtr, objc, objv,
+ &prefixObj)) {
+ case TCL_OK:
+ goto runResultingSubcommand;
+ case TCL_ERROR:
+ return TCL_ERROR;
+ case TCL_CONTINUE:
+ goto restartEnsembleParse;
+ }
+ }
+
+ /*
+ * We cannot determine what subcommand to hand off to, so generate a
+ * (standard) failure message. Note the one odd case compared with
+ * standard ensemble-like command, which is where a namespace has no
+ * exported commands at all...
+ */
+
+ Tcl_ResetResult(interp);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND",
+ TclGetString(subObj), NULL);
+ if (ensemblePtr->subcommandTable.numEntries == 0) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unknown subcommand \"%s\": namespace %s does not"
+ " export any commands", TclGetString(subObj),
+ ensemblePtr->nsPtr->fullName));
+ return TCL_ERROR;
+ }
+ errorObj = Tcl_ObjPrintf("unknown%s subcommand \"%s\": must be ",
+ (ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? " or ambiguous" : ""),
+ TclGetString(subObj));
+ if (ensemblePtr->subcommandTable.numEntries == 1) {
+ Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[0], -1);
+ } else {
+ int i;
+
+ for (i=0 ; i<ensemblePtr->subcommandTable.numEntries-1 ; i++) {
+ Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[i], -1);
+ Tcl_AppendToObj(errorObj, ", ", 2);
+ }
+ Tcl_AppendPrintfToObj(errorObj, "or %s",
+ ensemblePtr->subcommandArrayPtr[i]);
+ }
+ Tcl_SetObjResult(interp, errorObj);
+ return TCL_ERROR;
+}
+
+int
+TclClearRootEnsemble(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ TclResetRewriteEnsemble(interp, 1);
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclInitRewriteEnsemble --
+ *
+ * Applies a rewrite of arguments so that an ensemble subcommand will
+ * report error messages correctly for the overall command.
+ *
+ * Results:
+ * Whether this is the first rewrite applied, a value which must be
+ * passed to TclResetRewriteEnsemble when undoing this command's
+ * behaviour.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclInitRewriteEnsemble(
+ Tcl_Interp *interp,
+ int numRemoved,
+ int numInserted,
+ Tcl_Obj *const *objv)
+{
+ Interp *iPtr = (Interp *) interp;
+
+ int isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL);
+
+ if (isRootEnsemble) {
+ iPtr->ensembleRewrite.sourceObjs = objv;
+ iPtr->ensembleRewrite.numRemovedObjs = numRemoved;
+ iPtr->ensembleRewrite.numInsertedObjs = numInserted;
+ } else {
+ int numIns = iPtr->ensembleRewrite.numInsertedObjs;
+
+ if (numIns < numRemoved) {
+ iPtr->ensembleRewrite.numRemovedObjs += numRemoved - numIns;
+ iPtr->ensembleRewrite.numInsertedObjs = numInserted;
+ } else {
+ iPtr->ensembleRewrite.numInsertedObjs += numInserted - numRemoved;
+ }
+ }
+ return isRootEnsemble;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclResetRewriteEnsemble --
+ *
+ * Removes any rewrites applied to support proper reporting of error
+ * messages used in ensembles. Should be paired with
+ * TclInitRewriteEnsemble.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclResetRewriteEnsemble(
+ Tcl_Interp *interp,
+ int isRootEnsemble)
+{
+ Interp *iPtr = (Interp *) interp;
+
+ if (isRootEnsemble) {
+ iPtr->ensembleRewrite.sourceObjs = NULL;
+ iPtr->ensembleRewrite.numRemovedObjs = 0;
+ iPtr->ensembleRewrite.numInsertedObjs = 0;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclSpellFix --
+ *
+ * Record a spelling correction that needs making in the
+ * generation of the WrongNumArgs usage message.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Can create an alternative ensemble rewrite structure.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+FreeER(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Tcl_Obj **tmp = (Tcl_Obj **)data[0];
+
+ ckfree(tmp[2]);
+ ckfree(tmp);
+ return result;
+}
+
+void
+TclSpellFix(
+ Tcl_Interp *interp,
+ Tcl_Obj *const *objv,
+ int objc,
+ int badIdx,
+ Tcl_Obj *bad,
+ Tcl_Obj *fix)
+{
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Obj *const *search;
+ Tcl_Obj **store;
+ int idx;
+ int size;
+
+ if (iPtr->ensembleRewrite.sourceObjs == NULL) {
+ iPtr->ensembleRewrite.sourceObjs = objv;
+ iPtr->ensembleRewrite.numRemovedObjs = 0;
+ iPtr->ensembleRewrite.numInsertedObjs = 0;
+ }
+
+ /* Compute the valid length of the ensemble root */
+
+ size = iPtr->ensembleRewrite.numRemovedObjs + objc
+ - iPtr->ensembleRewrite.numInsertedObjs;
+
+ search = iPtr->ensembleRewrite.sourceObjs;
+ if (search[0] == NULL) {
+ /* Awful casting abuse here */
+ search = (Tcl_Obj *const *) search[1];
+ }
+
+ if (badIdx < iPtr->ensembleRewrite.numInsertedObjs) {
+ /*
+ * Misspelled value was inserted. We cannot directly jump
+ * to the bad value, but have to search.
+ */
+ idx = 1;
+ while (idx < size) {
+ if (search[idx] == bad) {
+ break;
+ }
+ idx++;
+ }
+ if (idx == size) {
+ return;
+ }
+ } else {
+ /* Jump to the misspelled value. */
+ idx = iPtr->ensembleRewrite.numRemovedObjs + badIdx
+ - iPtr->ensembleRewrite.numInsertedObjs;
+
+ /* Verify */
+ if (search[idx] != bad) {
+ Tcl_Panic("SpellFix: programming error");
+ }
+ }
+
+ search = iPtr->ensembleRewrite.sourceObjs;
+ if (search[0] == NULL) {
+ store = (Tcl_Obj **)search[2];
+ } else {
+ Tcl_Obj **tmp = ckalloc(3 * sizeof(Tcl_Obj *));
+ tmp[0] = NULL;
+ tmp[1] = (Tcl_Obj *)iPtr->ensembleRewrite.sourceObjs;
+ tmp[2] = (Tcl_Obj *)ckalloc(size * sizeof(Tcl_Obj *));
+ memcpy(tmp[2], tmp[1], size*sizeof(Tcl_Obj *));
+
+ iPtr->ensembleRewrite.sourceObjs = (Tcl_Obj *const *) tmp;
+ TclNRAddCallback(interp, FreeER, tmp, NULL, NULL, NULL);
+ store = (Tcl_Obj **)tmp[2];
+ }
+
+ store[idx] = fix;
+ Tcl_IncrRefCount(fix);
+ TclNRAddCallback(interp, TclNRReleaseValues, fix, NULL, NULL, NULL);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclFetchEnsembleRoot --
+ *
+ * Returns the root of ensemble rewriting, if any.
+ * If no root exists, returns objv instead.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *const *
+TclFetchEnsembleRoot(
+ Tcl_Interp *interp,
+ Tcl_Obj *const *objv,
+ int objc,
+ int *objcPtr)
+{
+ Interp *iPtr = (Interp *) interp;
+
+ if (iPtr->ensembleRewrite.sourceObjs) {
+ *objcPtr = objc + iPtr->ensembleRewrite.numRemovedObjs
+ - iPtr->ensembleRewrite.numInsertedObjs;
+ return iPtr->ensembleRewrite.sourceObjs;
+ }
+ *objcPtr = objc;
+ return objv;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * EnsmebleUnknownCallback --
+ *
+ * Helper for the ensemble engine that handles the procesing of unknown
+ * callbacks. See the user documentation of the ensemble unknown handler
+ * for details; this function is only ever called when such a function is
+ * defined, and is only ever called once per ensemble dispatch (i.e. if a
+ * reparse still fails, this isn't called again).
+ *
+ * Results:
+ * TCL_OK - *prefixObjPtr contains the command words to dispatch
+ * to.
+ * TCL_CONTINUE - Need to reparse (*prefixObjPtr is invalid).
+ * TCL_ERROR - Something went wrong! Error message in interpreter.
+ *
+ * Side effects:
+ * Calls the Tcl interpreter, so arbitrary.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline int
+EnsembleUnknownCallback(
+ Tcl_Interp *interp,
+ EnsembleConfig *ensemblePtr,
+ int objc,
+ Tcl_Obj *const objv[],
+ Tcl_Obj **prefixObjPtr)
+{
+ int paramc, i, result, prefixObjc;
+ Tcl_Obj **paramv, *unknownCmd, *ensObj;
+
+ /*
+ * Create the unknown command callback to determine what to do.
+ */
+
+ unknownCmd = Tcl_DuplicateObj(ensemblePtr->unknownHandler);
+ TclNewObj(ensObj);
+ Tcl_GetCommandFullName(interp, ensemblePtr->token, ensObj);
+ Tcl_ListObjAppendElement(NULL, unknownCmd, ensObj);
+ for (i=1 ; i<objc ; i++) {
+ Tcl_ListObjAppendElement(NULL, unknownCmd, objv[i]);
+ }
+ TclListObjGetElements(NULL, unknownCmd, &paramc, &paramv);
+ Tcl_IncrRefCount(unknownCmd);
+
+ /*
+ * Now call the unknown handler. (We don't bother NRE-enabling this; deep
+ * recursing through unknown handlers is horribly perverse.) Note that it
+ * is always an error for an unknown handler to delete its ensemble; don't
+ * do that!
+ */
+
+ Tcl_Preserve(ensemblePtr);
+ TclSkipTailcall(interp);
+ result = Tcl_EvalObjv(interp, paramc, paramv, 0);
+ if ((result == TCL_OK) && (ensemblePtr->flags & ENSEMBLE_DEAD)) {
+ if (!Tcl_InterpDeleted(interp)) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "unknown subcommand handler deleted its ensemble", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "UNKNOWN_DELETED",
+ NULL);
+ }
+ result = TCL_ERROR;
+ }
+ Tcl_Release(ensemblePtr);
+
+ /*
+ * If we succeeded, we should either have a list of words that form the
+ * command to be executed, or an empty list. In the empty-list case, the
+ * ensemble is believed to be updated so we should ask the ensemble engine
+ * to reparse the original command.
+ */
+
+ if (result == TCL_OK) {
+ *prefixObjPtr = Tcl_GetObjResult(interp);
+ Tcl_IncrRefCount(*prefixObjPtr);
+ TclDecrRefCount(unknownCmd);
+ Tcl_ResetResult(interp);
+
+ /*
+ * Namespace is still there. Check if the result is a valid list. If
+ * it is, and it is non-empty, that list is what we are using as our
+ * replacement.
+ */
+
+ if (TclListObjLength(interp, *prefixObjPtr, &prefixObjc) != TCL_OK) {
+ TclDecrRefCount(*prefixObjPtr);
+ Tcl_AddErrorInfo(interp, "\n while parsing result of "
+ "ensemble unknown subcommand handler");
+ return TCL_ERROR;
+ }
+ if (prefixObjc > 0) {
+ return TCL_OK;
+ }
+
+ /*
+ * Namespace alive & empty result => reparse.
+ */
+
+ TclDecrRefCount(*prefixObjPtr);
+ return TCL_CONTINUE;
+ }
+
+ /*
+ * Oh no! An exceptional result. Convert to an error.
+ */
+
+ if (!Tcl_InterpDeleted(interp)) {
+ if (result != TCL_ERROR) {
+ Tcl_ResetResult(interp);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "unknown subcommand handler returned bad code: ", -1));
+ switch (result) {
+ case TCL_RETURN:
+ Tcl_AppendToObj(Tcl_GetObjResult(interp), "return", -1);
+ break;
+ case TCL_BREAK:
+ Tcl_AppendToObj(Tcl_GetObjResult(interp), "break", -1);
+ break;
+ case TCL_CONTINUE:
+ Tcl_AppendToObj(Tcl_GetObjResult(interp), "continue", -1);
+ break;
+ default:
+ Tcl_AppendPrintfToObj(Tcl_GetObjResult(interp), "%d", result);
+ }
+ Tcl_AddErrorInfo(interp, "\n result of "
+ "ensemble unknown subcommand handler: ");
+ Tcl_AppendObjToErrorInfo(interp, unknownCmd);
+ Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "UNKNOWN_RESULT",
+ NULL);
+ } else {
+ Tcl_AddErrorInfo(interp,
+ "\n (ensemble unknown subcommand handler)");
+ }
+ }
+ TclDecrRefCount(unknownCmd);
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * MakeCachedEnsembleCommand --
+ *
+ * Cache what we've computed so far; it's not nice to repeatedly copy
+ * strings about. Note that to do this, we start by deleting any old
+ * representation that there was (though if it was an out of date
+ * ensemble rep, we can skip some of the deallocation process.)
+ *
+ * Results:
+ * None
+ *
+ * Side effects:
+ * Alters the internal representation of the first object parameter.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+MakeCachedEnsembleCommand(
+ Tcl_Obj *objPtr,
+ EnsembleConfig *ensemblePtr,
+ Tcl_HashEntry *hPtr,
+ Tcl_Obj *fix)
+{
+ register EnsembleCmdRep *ensembleCmd;
+
+ if (objPtr->typePtr == &ensembleCmdType) {
+ ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1;
+ TclCleanupCommandMacro(ensembleCmd->token);
+ if (ensembleCmd->fix) {
+ Tcl_DecrRefCount(ensembleCmd->fix);
+ }
+ } else {
+ /*
+ * Kill the old internal rep, and replace it with a brand new one of
+ * our own.
+ */
+
+ TclFreeIntRep(objPtr);
+ ensembleCmd = ckalloc(sizeof(EnsembleCmdRep));
+ objPtr->internalRep.twoPtrValue.ptr1 = ensembleCmd;
+ objPtr->typePtr = &ensembleCmdType;
+ }
+
+ /*
+ * Populate the internal rep.
+ */
+
+ ensembleCmd->epoch = ensemblePtr->epoch;
+ ensembleCmd->token = (Command *) ensemblePtr->token;
+ ensembleCmd->token->refCount++;
+ if (fix) {
+ Tcl_IncrRefCount(fix);
+ }
+ ensembleCmd->fix = fix;
+ ensembleCmd->hPtr = hPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DeleteEnsembleConfig --
+ *
+ * Destroys the data structure used to represent an ensemble. This is
+ * called when the ensemble's command is deleted (which happens
+ * automatically if the ensemble's namespace is deleted.) Maintainers
+ * should note that ensembles should be deleted by deleting their
+ * commands.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Memory is (eventually) deallocated.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+ClearTable(
+ EnsembleConfig *ensemblePtr)
+{
+ Tcl_HashTable *hash = &ensemblePtr->subcommandTable;
+
+ if (hash->numEntries != 0) {
+ Tcl_HashSearch search;
+ Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(hash, &search);
+
+ while (hPtr != NULL) {
+ Tcl_Obj *prefixObj = Tcl_GetHashValue(hPtr);
+ Tcl_DecrRefCount(prefixObj);
+ hPtr = Tcl_NextHashEntry(&search);
+ }
+ ckfree((char *) ensemblePtr->subcommandArrayPtr);
+ }
+ Tcl_DeleteHashTable(hash);
+}
+
+static void
+DeleteEnsembleConfig(
+ ClientData clientData)
+{
+ EnsembleConfig *ensemblePtr = clientData;
+ Namespace *nsPtr = ensemblePtr->nsPtr;
+
+ /*
+ * Unlink from the ensemble chain if it has not been marked as having been
+ * done already.
+ */
+
+ if (ensemblePtr->next != ensemblePtr) {
+ EnsembleConfig *ensPtr = (EnsembleConfig *) nsPtr->ensembles;
+
+ if (ensPtr == ensemblePtr) {
+ nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr->next;
+ } else {
+ while (ensPtr != NULL) {
+ if (ensPtr->next == ensemblePtr) {
+ ensPtr->next = ensemblePtr->next;
+ break;
+ }
+ ensPtr = ensPtr->next;
+ }
+ }
+ }
+
+ /*
+ * Mark the namespace as dead so code that uses Tcl_Preserve() can tell
+ * whether disaster happened anyway.
+ */
+
+ ensemblePtr->flags |= ENSEMBLE_DEAD;
+
+ /*
+ * Kill the pointer-containing fields.
+ */
+
+ ClearTable(ensemblePtr);
+ if (ensemblePtr->subcmdList != NULL) {
+ Tcl_DecrRefCount(ensemblePtr->subcmdList);
+ }
+ if (ensemblePtr->parameterList != NULL) {
+ Tcl_DecrRefCount(ensemblePtr->parameterList);
+ }
+ if (ensemblePtr->subcommandDict != NULL) {
+ Tcl_DecrRefCount(ensemblePtr->subcommandDict);
+ }
+ if (ensemblePtr->unknownHandler != NULL) {
+ Tcl_DecrRefCount(ensemblePtr->unknownHandler);
+ }
+
+ /*
+ * Arrange for the structure to be reclaimed. Note that this is complex
+ * because we have to make sure that we can react sensibly when an
+ * ensemble is deleted during the process of initialising the ensemble
+ * (especially the unknown callback.)
+ */
+
+ Tcl_EventuallyFree(ensemblePtr, TCL_DYNAMIC);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * BuildEnsembleConfig --
+ *
+ * Create the internal data structures that describe how an ensemble
+ * looks, being a hash mapping from the simple command name to the Tcl list
+ * that describes the implementation prefix words, and a sorted array of
+ * the names to allow for reasonably efficient unambiguous prefix handling.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Reallocates and rebuilds the hash table and array stored at the
+ * ensemblePtr argument. For large ensembles or large namespaces, this is
+ * a potentially expensive operation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+BuildEnsembleConfig(
+ EnsembleConfig *ensemblePtr)
+{
+ Tcl_HashSearch search; /* Used for scanning the set of commands in
+ * the namespace that backs up this
+ * ensemble. */
+ int i, j, isNew;
+ Tcl_HashTable *hash = &ensemblePtr->subcommandTable;
+ Tcl_HashEntry *hPtr;
+ Tcl_Obj *mapDict = ensemblePtr->subcommandDict;
+ Tcl_Obj *subList = ensemblePtr->subcmdList;
+
+ ClearTable(ensemblePtr);
+ Tcl_InitHashTable(hash, TCL_STRING_KEYS);
+
+ if (subList) {
+ int subc;
+ Tcl_Obj **subv, *target, *cmdObj, *cmdPrefixObj;
+ char *name;
+
+ /*
+ * There is a list of exactly what subcommands go in the table.
+ * Must determine the target for each.
+ */
+
+ Tcl_ListObjGetElements(NULL, subList, &subc, &subv);
+ if (subList == mapDict) {
+ /*
+ * Strange case where explicit list of subcommands is same value
+ * as the dict mapping to targets.
+ */
+
+ for (i = 0; i < subc; i += 2) {
+ name = TclGetString(subv[i]);
+ hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
+ if (!isNew) {
+ cmdObj = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
+ Tcl_DecrRefCount(cmdObj);
+ }
+ Tcl_SetHashValue(hPtr, subv[i+1]);
+ Tcl_IncrRefCount(subv[i+1]);
+
+ name = TclGetString(subv[i+1]);
+ hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
+ if (isNew) {
+ cmdObj = Tcl_NewStringObj(name, -1);
+ cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
+ Tcl_SetHashValue(hPtr, cmdPrefixObj);
+ Tcl_IncrRefCount(cmdPrefixObj);
+ }
+ }
+ } else {
+ /* Usual case where we can freely act on the list and dict. */
+
+ for (i = 0; i < subc; i++) {
+ name = TclGetString(subv[i]);
+ hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
+ if (!isNew) {
+ continue;
+ }
+
+ /* Lookup target in the dictionary */
+ if (mapDict) {
+ Tcl_DictObjGet(NULL, mapDict, subv[i], &target);
+ if (target) {
+ Tcl_SetHashValue(hPtr, target);
+ Tcl_IncrRefCount(target);
+ continue;
+ }
+ }
+
+ /*
+ * target was not in the dictionary so map onto the namespace.
+ * Note in this case that we do not guarantee that the
+ * command is actually there; that is the programmer's
+ * responsibility (or [::unknown] of course).
+ */
+ cmdObj = Tcl_NewStringObj(name, -1);
+ cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
+ Tcl_SetHashValue(hPtr, cmdPrefixObj);
+ Tcl_IncrRefCount(cmdPrefixObj);
+ }
+ }
+ } else if (mapDict) {
+ /*
+ * No subcmd list, but we do have a mapping dictionary so we should
+ * use the keys of that. Convert the dictionary's contents into the
+ * form required for the ensemble's internal hashtable.
+ */
+
+ Tcl_DictSearch dictSearch;
+ Tcl_Obj *keyObj, *valueObj;
+ int done;
+
+ Tcl_DictObjFirst(NULL, ensemblePtr->subcommandDict, &dictSearch,
+ &keyObj, &valueObj, &done);
+ while (!done) {
+ char *name = TclGetString(keyObj);
+
+ hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
+ Tcl_SetHashValue(hPtr, valueObj);
+ Tcl_IncrRefCount(valueObj);
+ Tcl_DictObjNext(&dictSearch, &keyObj, &valueObj, &done);
+ }
+ } else {
+ /*
+ * Discover what commands are actually exported by the namespace.
+ * What we have is an array of patterns and a hash table whose keys
+ * are the command names exported by the namespace (the contents do
+ * not matter here.) We must find out what commands are actually
+ * exported by filtering each command in the namespace against each of
+ * the patterns in the export list. Note that we use an intermediate
+ * hash table to make memory management easier, and because that makes
+ * exact matching far easier too.
+ *
+ * Suggestion for future enhancement: compute the unique prefixes and
+ * place them in the hash too, which should make for even faster
+ * matching.
+ */
+
+ hPtr = Tcl_FirstHashEntry(&ensemblePtr->nsPtr->cmdTable, &search);
+ for (; hPtr!= NULL ; hPtr=Tcl_NextHashEntry(&search)) {
+ char *nsCmdName = /* Name of command in namespace. */
+ Tcl_GetHashKey(&ensemblePtr->nsPtr->cmdTable, hPtr);
+
+ for (i=0 ; i<ensemblePtr->nsPtr->numExportPatterns ; i++) {
+ if (Tcl_StringMatch(nsCmdName,
+ ensemblePtr->nsPtr->exportArrayPtr[i])) {
+ hPtr = Tcl_CreateHashEntry(hash, nsCmdName, &isNew);
+
+ /*
+ * Remember, hash entries have a full reference to the
+ * substituted part of the command (as a list) as their
+ * content!
+ */
+
+ if (isNew) {
+ Tcl_Obj *cmdObj, *cmdPrefixObj;
+
+ cmdObj = Tcl_NewStringObj(nsCmdName, -1);
+ cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
+ Tcl_SetHashValue(hPtr, cmdPrefixObj);
+ Tcl_IncrRefCount(cmdPrefixObj);
+ }
+ break;
+ }
+ }
+ }
+ }
+
+ if (hash->numEntries == 0) {
+ ensemblePtr->subcommandArrayPtr = NULL;
+ return;
+ }
+
+ /*
+ * Create a sorted array of all subcommands in the ensemble; hash tables
+ * are all very well for a quick look for an exact match, but they can't
+ * determine things like whether a string is a prefix of another (not
+ * without lots of preparation anyway) and they're no good for when we're
+ * generating the error message either.
+ *
+ * We do this by filling an array with the names (we use the hash keys
+ * directly to save a copy, since any time we change the array we change
+ * the hash too, and vice versa) and running quicksort over the array.
+ */
+
+ ensemblePtr->subcommandArrayPtr =
+ ckalloc(sizeof(char *) * hash->numEntries);
+
+ /*
+ * Fill array from both ends as this makes us less likely to end up with
+ * performance problems in qsort(), which is good. Note that doing this
+ * makes this code much more opaque, but the naive alternatve:
+ *
+ * for (hPtr=Tcl_FirstHashEntry(hash,&search),i=0 ;
+ * hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search),i++) {
+ * ensemblePtr->subcommandArrayPtr[i] = Tcl_GetHashKey(hash, &hPtr);
+ * }
+ *
+ * can produce long runs of precisely ordered table entries when the
+ * commands in the namespace are declared in a sorted fashion (an ordering
+ * some people like) and the hashing functions (or the command names
+ * themselves) are fairly unfortunate. By filling from both ends, it
+ * requires active malice (and probably a debugger) to get qsort() to have
+ * awful runtime behaviour.
+ */
+
+ i = 0;
+ j = hash->numEntries;
+ hPtr = Tcl_FirstHashEntry(hash, &search);
+ while (hPtr != NULL) {
+ ensemblePtr->subcommandArrayPtr[i++] = Tcl_GetHashKey(hash, hPtr);
+ hPtr = Tcl_NextHashEntry(&search);
+ if (hPtr == NULL) {
+ break;
+ }
+ ensemblePtr->subcommandArrayPtr[--j] = Tcl_GetHashKey(hash, hPtr);
+ hPtr = Tcl_NextHashEntry(&search);
+ }
+ if (hash->numEntries > 1) {
+ qsort(ensemblePtr->subcommandArrayPtr, (unsigned) hash->numEntries,
+ sizeof(char *), NsEnsembleStringOrder);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * NsEnsembleStringOrder --
+ *
+ * Helper function to compare two pointers to two strings for use with
+ * qsort().
+ *
+ * Results:
+ * -1 if the first string is smaller, 1 if the second string is smaller,
+ * and 0 if they are equal.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+NsEnsembleStringOrder(
+ const void *strPtr1,
+ const void *strPtr2)
+{
+ return strcmp(*(const char **)strPtr1, *(const char **)strPtr2);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeEnsembleCmdRep --
+ *
+ * Destroys the internal representation of a Tcl_Obj that has been
+ * holding information about a command in an ensemble.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Memory is deallocated. If this held the last reference to a
+ * namespace's main structure, that main structure will also be
+ * destroyed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FreeEnsembleCmdRep(
+ Tcl_Obj *objPtr)
+{
+ EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1;
+
+ TclCleanupCommandMacro(ensembleCmd->token);
+ if (ensembleCmd->fix) {
+ Tcl_DecrRefCount(ensembleCmd->fix);
+ }
+ ckfree(ensembleCmd);
+ objPtr->typePtr = NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DupEnsembleCmdRep --
+ *
+ * Makes one Tcl_Obj into a copy of another that is a subcommand of an
+ * ensemble.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Memory is allocated, and the namespace that the ensemble is built on
+ * top of gains another reference.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+DupEnsembleCmdRep(
+ Tcl_Obj *objPtr,
+ Tcl_Obj *copyPtr)
+{
+ EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1;
+ EnsembleCmdRep *ensembleCopy = ckalloc(sizeof(EnsembleCmdRep));
+
+ copyPtr->typePtr = &ensembleCmdType;
+ copyPtr->internalRep.twoPtrValue.ptr1 = ensembleCopy;
+ ensembleCopy->epoch = ensembleCmd->epoch;
+ ensembleCopy->token = ensembleCmd->token;
+ ensembleCopy->token->refCount++;
+ ensembleCopy->fix = ensembleCmd->fix;
+ if (ensembleCopy->fix) {
+ Tcl_IncrRefCount(ensembleCopy->fix);
+ }
+ ensembleCopy->hPtr = ensembleCmd->hPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileEnsemble --
+ *
+ * Procedure called to compile an ensemble command. Note that most
+ * ensembles are not compiled, since modifying a compiled ensemble causes
+ * a invalidation of all existing bytecode (expensive!) which is not
+ * normally warranted.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the subcommands of the
+ * ensemble at runtime if a compile-time mapping is possible.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileEnsemble(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ Tcl_Obj *mapObj, *subcmdObj, *targetCmdObj, *listObj, **elems;
+ Tcl_Obj *replaced = Tcl_NewObj(), *replacement;
+ Tcl_Command ensemble = (Tcl_Command) cmdPtr;
+ Command *oldCmdPtr = cmdPtr, *newCmdPtr;
+ int len, result, flags = 0, i, depth = 1, invokeAnyway = 0;
+ int ourResult = TCL_ERROR;
+ unsigned numBytes;
+ const char *word;
+ DefineLineInformation;
+
+ Tcl_IncrRefCount(replaced);
+ if (parsePtr->numWords < depth + 1) {
+ goto failed;
+ }
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ /*
+ * Too hard.
+ */
+
+ goto failed;
+ }
+
+ /*
+ * This is where we return to if we are parsing multiple nested compiled
+ * ensembles. [info object] is such a beast.
+ */
+
+ checkNextWord:
+ word = tokenPtr[1].start;
+ numBytes = tokenPtr[1].size;
+
+ /*
+ * There's a sporting chance we'll be able to compile this. But now we
+ * must check properly. To do that, check that we're compiling an ensemble
+ * that has a compilable command as its appropriate subcommand.
+ */
+
+ if (Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj) != TCL_OK
+ || mapObj == NULL) {
+ /*
+ * Either not an ensemble or a mapping isn't installed. Crud. Too hard
+ * to proceed.
+ */
+
+ goto failed;
+ }
+
+ /*
+ * Also refuse to compile anything that uses a formal parameter list for
+ * now, on the grounds that it is too complex.
+ */
+
+ if (Tcl_GetEnsembleParameterList(NULL, ensemble, &listObj) != TCL_OK
+ || listObj != NULL) {
+ /*
+ * Figuring out how to compile this has become too much. Bail out.
+ */
+
+ goto failed;
+ }
+
+ /*
+ * Next, get the flags. We need them on several code paths so that we can
+ * know whether we're to do prefix matching.
+ */
+
+ (void) Tcl_GetEnsembleFlags(NULL, ensemble, &flags);
+
+ /*
+ * Check to see if there's also a subcommand list; must check to see if
+ * the subcommand we are calling is in that list if it exists, since that
+ * list filters the entries in the map.
+ */
+
+ (void) Tcl_GetEnsembleSubcommandList(NULL, ensemble, &listObj);
+ if (listObj != NULL) {
+ int sclen;
+ const char *str;
+ Tcl_Obj *matchObj = NULL;
+
+ if (Tcl_ListObjGetElements(NULL, listObj, &len, &elems) != TCL_OK) {
+ goto failed;
+ }
+ for (i=0 ; i<len ; i++) {
+ str = Tcl_GetStringFromObj(elems[i], &sclen);
+ if ((sclen == (int) numBytes) && !memcmp(word, str, numBytes)) {
+ /*
+ * Exact match! Excellent!
+ */
+
+ result = Tcl_DictObjGet(NULL, mapObj,elems[i], &targetCmdObj);
+ if (result != TCL_OK || targetCmdObj == NULL) {
+ goto failed;
+ }
+ replacement = elems[i];
+ goto doneMapLookup;
+ }
+
+ /*
+ * Check to see if we've got a prefix match. A single prefix match
+ * is fine, and allows us to refine our dictionary lookup, but
+ * multiple prefix matches is a Bad Thing and will prevent us from
+ * making progress. Note that we cannot do the lookup immediately
+ * in the prefix case; might be another entry later in the list
+ * that causes things to fail.
+ */
+
+ if ((flags & TCL_ENSEMBLE_PREFIX)
+ && strncmp(word, str, numBytes) == 0) {
+ if (matchObj != NULL) {
+ goto failed;
+ }
+ matchObj = elems[i];
+ }
+ }
+ if (matchObj == NULL) {
+ goto failed;
+ }
+ result = Tcl_DictObjGet(NULL, mapObj, matchObj, &targetCmdObj);
+ if (result != TCL_OK || targetCmdObj == NULL) {
+ goto failed;
+ }
+ replacement = matchObj;
+ } else {
+ Tcl_DictSearch s;
+ int done, matched;
+ Tcl_Obj *tmpObj;
+
+ /*
+ * No map, so check the dictionary directly.
+ */
+
+ TclNewStringObj(subcmdObj, word, (int) numBytes);
+ result = Tcl_DictObjGet(NULL, mapObj, subcmdObj, &targetCmdObj);
+ if (result == TCL_OK && targetCmdObj != NULL) {
+ /*
+ * Got it. Skip the fiddling around with prefixes.
+ */
+
+ replacement = subcmdObj;
+ goto doneMapLookup;
+ }
+ TclDecrRefCount(subcmdObj);
+
+ /*
+ * We've not literally got a valid subcommand. But maybe we have a
+ * prefix. Check if prefix matches are allowed.
+ */
+
+ if (!(flags & TCL_ENSEMBLE_PREFIX)) {
+ goto failed;
+ }
+
+ /*
+ * Iterate over the keys in the dictionary, checking to see if we're a
+ * prefix.
+ */
+
+ Tcl_DictObjFirst(NULL, mapObj, &s, &subcmdObj, &tmpObj, &done);
+ matched = 0;
+ replacement = NULL; /* Silence, fool compiler! */
+ while (!done) {
+ if (strncmp(TclGetString(subcmdObj), word, numBytes) == 0) {
+ if (matched++) {
+ /*
+ * Must have matched twice! Not unique, so no point
+ * looking further.
+ */
+
+ break;
+ }
+ replacement = subcmdObj;
+ targetCmdObj = tmpObj;
+ }
+ Tcl_DictObjNext(&s, &subcmdObj, &tmpObj, &done);
+ }
+ Tcl_DictObjDone(&s);
+
+ /*
+ * If we have anything other than a single match, we've failed the
+ * unique prefix check.
+ */
+
+ if (matched != 1) {
+ invokeAnyway = 1;
+ goto failed;
+ }
+ }
+
+ /*
+ * OK, we definitely map to something. But what?
+ *
+ * The command we map to is the first word out of the map element. Note
+ * that we also reject dealing with multi-element rewrites if we are in a
+ * safe interpreter, as there is otherwise a (highly gnarly!) way to make
+ * Tcl crash open to exploit.
+ */
+
+ doneMapLookup:
+ Tcl_ListObjAppendElement(NULL, replaced, replacement);
+ if (Tcl_ListObjGetElements(NULL, targetCmdObj, &len, &elems) != TCL_OK) {
+ goto failed;
+ } else if (len != 1) {
+ /*
+ * Note that at this point we know we can't issue any special
+ * instruction sequence as the mapping isn't one that we support at
+ * the compiled level.
+ */
+
+ goto cleanup;
+ }
+ targetCmdObj = elems[0];
+
+ oldCmdPtr = cmdPtr;
+ Tcl_IncrRefCount(targetCmdObj);
+ newCmdPtr = (Command *) Tcl_GetCommandFromObj(interp, targetCmdObj);
+ TclDecrRefCount(targetCmdObj);
+ if (newCmdPtr == NULL || Tcl_IsSafe(interp)
+ || newCmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION
+ || newCmdPtr->flags & CMD_HAS_EXEC_TRACES
+ || ((Interp *)interp)->flags & DONT_COMPILE_CMDS_INLINE) {
+ /*
+ * Maps to an undefined command or a command without a compiler.
+ * Cannot compile.
+ */
+
+ goto cleanup;
+ }
+ cmdPtr = newCmdPtr;
+ depth++;
+
+ /*
+ * See whether we have a nested ensemble. If we do, we can go round the
+ * mulberry bush again, consuming the next word.
+ */
+
+ if (cmdPtr->compileProc == TclCompileEnsemble) {
+ tokenPtr = TokenAfter(tokenPtr);
+ if (parsePtr->numWords < depth + 1
+ || tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ /*
+ * Too hard because the user has done something unpleasant like
+ * omitting the sub-ensemble's command name or used a non-constant
+ * name for a sub-ensemble's command name; we respond by bailing
+ * out completely (this is a rare case). [Bug 6d2f249a01]
+ */
+
+ goto cleanup;
+ }
+ ensemble = (Tcl_Command) cmdPtr;
+ goto checkNextWord;
+ }
+
+ /*
+ * Now we've done the mapping process, can now actually try to compile.
+ * If there is a subcommand compiler and that successfully produces code,
+ * we'll use that. Otherwise, we fall back to generating opcodes to do the
+ * invoke at runtime.
+ */
+
+ invokeAnyway = 1;
+ if (TCL_OK == TclAttemptCompileProc(interp, parsePtr, depth, cmdPtr,
+ envPtr)) {
+ ourResult = TCL_OK;
+ goto cleanup;
+ }
+
+ /*
+ * Throw out any line information generated by the failed compile attempt.
+ */
+
+ while (mapPtr->nuloc - 1 > eclIndex) {
+ mapPtr->nuloc--;
+ ckfree(mapPtr->loc[mapPtr->nuloc].line);
+ mapPtr->loc[mapPtr->nuloc].line = NULL;
+ }
+
+ /*
+ * Reset the index of next command. Toss out any from failed nested
+ * partial compiles.
+ */
+
+ envPtr->numCommands = mapPtr->nuloc;
+
+ /*
+ * Failed to do a full compile for some reason. Try to do a direct invoke
+ * instead of going through the ensemble lookup process again.
+ */
+
+ failed:
+ if (depth < 250) {
+ if (depth > 1) {
+ if (!invokeAnyway) {
+ cmdPtr = oldCmdPtr;
+ depth--;
+ }
+ }
+ /*
+ * The length of the "replaced" list must be depth-1. Trim back
+ * any extra elements that might have been appended by failing
+ * pathways above.
+ */
+ (void) Tcl_ListObjReplace(NULL, replaced, depth-1, LIST_MAX, 0, NULL);
+
+ /*
+ * TODO: Reconsider whether we ought to call CompileToInvokedCommand()
+ * when depth==1. In that case we are choosing to emit the
+ * INST_INVOKE_REPLACE bytecode when there is in fact no replacing
+ * to be done. It would be equally functional and presumably more
+ * performant to fall through to cleanup below, return TCL_ERROR,
+ * and let the compiler harness emit the INST_INVOKE_STK
+ * implementation for us.
+ */
+
+ CompileToInvokedCommand(interp, parsePtr, replaced, cmdPtr, envPtr);
+ ourResult = TCL_OK;
+ }
+
+ /*
+ * Release the memory we allocated. If we've got here, we've either done
+ * something useful or we're in a case that we can't compile at all and
+ * we're just giving up.
+ */
+
+ cleanup:
+ Tcl_DecrRefCount(replaced);
+ return ourResult;
+}
+
+int
+TclAttemptCompileProc(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ int depth,
+ Command *cmdPtr,
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ int result, i;
+ Tcl_Token *saveTokenPtr = parsePtr->tokenPtr;
+ int savedStackDepth = envPtr->currStackDepth;
+ unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart;
+ int savedAuxDataArrayNext = envPtr->auxDataArrayNext;
+ int savedExceptArrayNext = envPtr->exceptArrayNext;
+#ifdef TCL_COMPILE_DEBUG
+ int savedExceptDepth = envPtr->exceptDepth;
+#endif
+ DefineLineInformation;
+
+ if (cmdPtr->compileProc == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Advance parsePtr->tokenPtr so that it points at the last subcommand.
+ * This will be wrong, but it will not matter, and it will put the
+ * tokens for the arguments in the right place without the needed to
+ * allocate a synthetic Tcl_Parse struct, or copy tokens around.
+ */
+
+ for (i = 0; i < depth - 1; i++) {
+ parsePtr->tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ }
+ parsePtr->numWords -= (depth - 1);
+
+ /*
+ * Shift the line information arrays to account for different word
+ * index values.
+ */
+
+ mapPtr->loc[eclIndex].line += (depth - 1);
+ mapPtr->loc[eclIndex].next += (depth - 1);
+
+ /*
+ * Hand off compilation to the subcommand compiler. At last!
+ */
+
+ result = cmdPtr->compileProc(interp, parsePtr, cmdPtr, envPtr);
+
+ /*
+ * Undo the shift.
+ */
+
+ mapPtr->loc[eclIndex].line -= (depth - 1);
+ mapPtr->loc[eclIndex].next -= (depth - 1);
+
+ parsePtr->numWords += (depth - 1);
+ parsePtr->tokenPtr = saveTokenPtr;
+
+ /*
+ * If our target failed to compile, revert any data from failed partial
+ * compiles. Note that envPtr->numCommands need not be checked because
+ * we avoid compiling subcommands that recursively call TclCompileScript().
+ */
+
+#ifdef TCL_COMPILE_DEBUG
+ if (envPtr->exceptDepth != savedExceptDepth) {
+ Tcl_Panic("ExceptionRange Starts and Ends do not balance");
+ }
+#endif
+
+ if (result != TCL_OK) {
+ ExceptionAux *auxPtr = envPtr->exceptAuxArrayPtr;
+
+ for (i = 0; i < savedExceptArrayNext; i++) {
+ while (auxPtr->numBreakTargets > 0
+ && auxPtr->breakTargets[auxPtr->numBreakTargets - 1]
+ >= savedCodeNext) {
+ auxPtr->numBreakTargets--;
+ }
+ while (auxPtr->numContinueTargets > 0
+ && auxPtr->continueTargets[auxPtr->numContinueTargets - 1]
+ >= savedCodeNext) {
+ auxPtr->numContinueTargets--;
+ }
+ auxPtr++;
+ }
+ envPtr->exceptArrayNext = savedExceptArrayNext;
+
+ if (savedAuxDataArrayNext != envPtr->auxDataArrayNext) {
+ AuxData *auxDataPtr = envPtr->auxDataArrayPtr;
+ AuxData *auxDataEnd = auxDataPtr;
+
+ auxDataPtr += savedAuxDataArrayNext;
+ auxDataEnd += envPtr->auxDataArrayNext;
+
+ while (auxDataPtr < auxDataEnd) {
+ if (auxDataPtr->type->freeProc != NULL) {
+ auxDataPtr->type->freeProc(auxDataPtr->clientData);
+ }
+ auxDataPtr++;
+ }
+ envPtr->auxDataArrayNext = savedAuxDataArrayNext;
+ }
+ envPtr->currStackDepth = savedStackDepth;
+ envPtr->codeNext = envPtr->codeStart + savedCodeNext;
+#ifdef TCL_COMPILE_DEBUG
+ } else {
+ /*
+ * Confirm that the command compiler generated a single value on
+ * the stack as its result. This is only done in debugging mode,
+ * as it *should* be correct and normal users have no reasonable
+ * way to fix it anyway.
+ */
+
+ int diff = envPtr->currStackDepth - savedStackDepth;
+
+ if (diff != 1) {
+ Tcl_Panic("bad stack adjustment when compiling"
+ " %.*s (was %d instead of 1)", parsePtr->tokenPtr->size,
+ parsePtr->tokenPtr->start, diff);
+ }
+#endif
+ }
+
+ return result;
+}
+
+/*
+ * How to compile a subcommand to a _replacing_ invoke of its implementation
+ * command.
+ */
+
+static void
+CompileToInvokedCommand(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Tcl_Obj *replacements,
+ Command *cmdPtr,
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Token *tokPtr;
+ Tcl_Obj *objPtr, **words;
+ char *bytes;
+ int length, i, numWords, cmdLit, extraLiteralFlags = LITERAL_CMD_NAME;
+ DefineLineInformation;
+
+ /*
+ * Push the words of the command. Take care; the command words may be
+ * scripts that have backslashes in them, and [info frame 0] can see the
+ * difference. Hence the call to TclContinuationsEnterDerived...
+ */
+
+ Tcl_ListObjGetElements(NULL, replacements, &numWords, &words);
+ for (i = 0, tokPtr = parsePtr->tokenPtr; i < parsePtr->numWords;
+ i++, tokPtr = TokenAfter(tokPtr)) {
+ if (i > 0 && i < numWords+1) {
+ bytes = Tcl_GetStringFromObj(words[i-1], &length);
+ PushLiteral(envPtr, bytes, length);
+ continue;
+ }
+
+ SetLineInformation(i);
+ if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+ int literal = TclRegisterNewLiteral(envPtr,
+ tokPtr[1].start, tokPtr[1].size);
+
+ if (envPtr->clNext) {
+ TclContinuationsEnterDerived(
+ TclFetchLiteral(envPtr, literal),
+ tokPtr[1].start - envPtr->source,
+ envPtr->clNext);
+ }
+ TclEmitPush(literal, envPtr);
+ } else {
+ CompileTokens(envPtr, tokPtr, interp);
+ }
+ }
+
+ /*
+ * Push the name of the command we're actually dispatching to as part of
+ * the implementation.
+ */
+
+ objPtr = Tcl_NewObj();
+ Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr);
+ bytes = Tcl_GetStringFromObj(objPtr, &length);
+ if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) {
+ extraLiteralFlags |= LITERAL_UNSHARED;
+ }
+ cmdLit = TclRegisterLiteral(envPtr, (char *)bytes, length, extraLiteralFlags);
+ TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLit), cmdPtr);
+ TclEmitPush(cmdLit, envPtr);
+ TclDecrRefCount(objPtr);
+
+ /*
+ * Do the replacing dispatch.
+ */
+
+ TclEmitInvoke(envPtr, INST_INVOKE_REPLACE, parsePtr->numWords,numWords+1);
+}
+
+/*
+ * Helpers that do issuing of instructions for commands that "don't have
+ * compilers" (well, they do; these). They all work by just generating base
+ * code to invoke the command; they're intended for ensemble subcommands so
+ * that the costs of INST_INVOKE_REPLACE can be avoided where we can work out
+ * that they're not needed.
+ *
+ * Note that these are NOT suitable for commands where there's an argument
+ * that is a script, as an [info level] or [info frame] in the inner context
+ * can see the difference.
+ */
+
+static int
+CompileBasicNArgCommand(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Obj *objPtr = Tcl_NewObj();
+
+ Tcl_IncrRefCount(objPtr);
+ Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr);
+ TclCompileInvocation(interp, parsePtr->tokenPtr, objPtr,
+ parsePtr->numWords, envPtr);
+ Tcl_DecrRefCount(objPtr);
+ return TCL_OK;
+}
+
+int
+TclCompileBasic0ArgCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * Verify that the number of arguments is correct; that's the only case
+ * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
+ * which is the only code that sees the shenanigans of ensemble dispatch.
+ */
+
+ if (parsePtr->numWords != 1) {
+ return TCL_ERROR;
+ }
+
+ return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
+}
+
+int
+TclCompileBasic1ArgCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * Verify that the number of arguments is correct; that's the only case
+ * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
+ * which is the only code that sees the shenanigans of ensemble dispatch.
+ */
+
+ if (parsePtr->numWords != 2) {
+ return TCL_ERROR;
+ }
+
+ return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
+}
+
+int
+TclCompileBasic2ArgCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * Verify that the number of arguments is correct; that's the only case
+ * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
+ * which is the only code that sees the shenanigans of ensemble dispatch.
+ */
+
+ if (parsePtr->numWords != 3) {
+ return TCL_ERROR;
+ }
+
+ return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
+}
+
+int
+TclCompileBasic3ArgCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * Verify that the number of arguments is correct; that's the only case
+ * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
+ * which is the only code that sees the shenanigans of ensemble dispatch.
+ */
+
+ if (parsePtr->numWords != 4) {
+ return TCL_ERROR;
+ }
+
+ return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
+}
+
+int
+TclCompileBasic0Or1ArgCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * Verify that the number of arguments is correct; that's the only case
+ * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
+ * which is the only code that sees the shenanigans of ensemble dispatch.
+ */
+
+ if (parsePtr->numWords != 1 && parsePtr->numWords != 2) {
+ return TCL_ERROR;
+ }
+
+ return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
+}
+
+int
+TclCompileBasic1Or2ArgCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * Verify that the number of arguments is correct; that's the only case
+ * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
+ * which is the only code that sees the shenanigans of ensemble dispatch.
+ */
+
+ if (parsePtr->numWords != 2 && parsePtr->numWords != 3) {
+ return TCL_ERROR;
+ }
+
+ return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
+}
+
+int
+TclCompileBasic2Or3ArgCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * Verify that the number of arguments is correct; that's the only case
+ * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
+ * which is the only code that sees the shenanigans of ensemble dispatch.
+ */
+
+ if (parsePtr->numWords != 3 && parsePtr->numWords != 4) {
+ return TCL_ERROR;
+ }
+
+ return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
+}
+
+int
+TclCompileBasic0To2ArgCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * Verify that the number of arguments is correct; that's the only case
+ * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
+ * which is the only code that sees the shenanigans of ensemble dispatch.
+ */
+
+ if (parsePtr->numWords < 1 || parsePtr->numWords > 3) {
+ return TCL_ERROR;
+ }
+
+ return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
+}
+
+int
+TclCompileBasic1To3ArgCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * Verify that the number of arguments is correct; that's the only case
+ * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
+ * which is the only code that sees the shenanigans of ensemble dispatch.
+ */
+
+ if (parsePtr->numWords < 2 || parsePtr->numWords > 4) {
+ return TCL_ERROR;
+ }
+
+ return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
+}
+
+int
+TclCompileBasicMin0ArgCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * Verify that the number of arguments is correct; that's the only case
+ * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
+ * which is the only code that sees the shenanigans of ensemble dispatch.
+ */
+
+ if (parsePtr->numWords < 1) {
+ return TCL_ERROR;
+ }
+
+ return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
+}
+
+int
+TclCompileBasicMin1ArgCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * Verify that the number of arguments is correct; that's the only case
+ * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
+ * which is the only code that sees the shenanigans of ensemble dispatch.
+ */
+
+ if (parsePtr->numWords < 2) {
+ return TCL_ERROR;
+ }
+
+ return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
+}
+
+int
+TclCompileBasicMin2ArgCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * Verify that the number of arguments is correct; that's the only case
+ * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
+ * which is the only code that sees the shenanigans of ensemble dispatch.
+ */
+
+ if (parsePtr->numWords < 3) {
+ return TCL_ERROR;
+ }
+
+ return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclInt.h b/generic/tclInt.h
new file mode 100644
index 0000000..567a28c
--- /dev/null
+++ b/generic/tclInt.h
@@ -0,0 +1,4905 @@
+/*
+ * tclInt.h --
+ *
+ * Declarations of things used internally by the Tcl interpreter.
+ *
+ * Copyright (c) 1987-1993 The Regents of the University of California.
+ * Copyright (c) 1993-1997 Lucent Technologies.
+ * Copyright (c) 1994-1998 Sun Microsystems, Inc.
+ * Copyright (c) 1998-1999 by Scriptics Corporation.
+ * Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved.
+ * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
+ * Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved.
+ * Copyright (c) 2008 by Miguel Sofer. All rights reserved.
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ */
+
+#ifndef _TCLINT
+#define _TCLINT
+
+/*
+ * Some numerics configuration options.
+ */
+
+#undef ACCEPT_NAN
+
+/*
+ * Common include files needed by most of the Tcl source files are included
+ * here, so that system-dependent personalizations for the include files only
+ * have to be made in once place. This results in a few extra includes, but
+ * greater modularity. The order of the three groups of #includes is
+ * important. For example, stdio.h is needed by tcl.h.
+ */
+
+#include "tclPort.h"
+
+#include <stdio.h>
+
+#include <ctype.h>
+#ifdef NO_STDLIB_H
+# include "../compat/stdlib.h"
+#else
+# include <stdlib.h>
+#endif
+#ifdef NO_STRING_H
+#include "../compat/string.h"
+#else
+#include <string.h>
+#endif
+#if defined(STDC_HEADERS) || defined(__STDC__) || defined(__C99__FUNC__) \
+ || defined(__cplusplus) || defined(_MSC_VER)
+#include <stddef.h>
+#else
+typedef int ptrdiff_t;
+#endif
+
+/*
+ * Ensure WORDS_BIGENDIAN is defined correctly:
+ * Needs to happen here in addition to configure to work with fat compiles on
+ * Darwin (where configure runs only once for multiple architectures).
+ */
+
+#ifdef HAVE_SYS_TYPES_H
+# include <sys/types.h>
+#endif
+#ifdef HAVE_SYS_PARAM_H
+# include <sys/param.h>
+#endif
+#ifdef BYTE_ORDER
+# ifdef BIG_ENDIAN
+# if BYTE_ORDER == BIG_ENDIAN
+# undef WORDS_BIGENDIAN
+# define WORDS_BIGENDIAN 1
+# endif
+# endif
+# ifdef LITTLE_ENDIAN
+# if BYTE_ORDER == LITTLE_ENDIAN
+# undef WORDS_BIGENDIAN
+# endif
+# endif
+#endif
+
+/*
+ * Used to tag functions that are only to be visible within the module being
+ * built and not outside it (where this is supported by the linker).
+ */
+
+#ifndef MODULE_SCOPE
+# ifdef __cplusplus
+# define MODULE_SCOPE extern "C"
+# else
+# define MODULE_SCOPE extern
+# endif
+#endif
+
+/*
+ * Macros used to cast between pointers and integers (e.g. when storing an int
+ * in ClientData), on 64-bit architectures they avoid gcc warning about "cast
+ * to/from pointer from/to integer of different size".
+ */
+
+#if !defined(INT2PTR) && !defined(PTR2INT)
+# if defined(HAVE_INTPTR_T) || defined(intptr_t)
+# define INT2PTR(p) ((void *)(intptr_t)(p))
+# define PTR2INT(p) ((int)(intptr_t)(p))
+# else
+# define INT2PTR(p) ((void *)(p))
+# define PTR2INT(p) ((int)(p))
+# endif
+#endif
+#if !defined(UINT2PTR) && !defined(PTR2UINT)
+# if defined(HAVE_UINTPTR_T) || defined(uintptr_t)
+# define UINT2PTR(p) ((void *)(uintptr_t)(p))
+# define PTR2UINT(p) ((unsigned int)(uintptr_t)(p))
+# else
+# define UINT2PTR(p) ((void *)(p))
+# define PTR2UINT(p) ((unsigned int)(p))
+# endif
+#endif
+
+#if defined(_WIN32) && defined(_MSC_VER)
+# define vsnprintf _vsnprintf
+#endif
+
+/*
+ * The following procedures allow namespaces to be customized to support
+ * special name resolution rules for commands/variables.
+ */
+
+struct Tcl_ResolvedVarInfo;
+
+typedef Tcl_Var (Tcl_ResolveRuntimeVarProc)(Tcl_Interp *interp,
+ struct Tcl_ResolvedVarInfo *vinfoPtr);
+
+typedef void (Tcl_ResolveVarDeleteProc)(struct Tcl_ResolvedVarInfo *vinfoPtr);
+
+/*
+ * The following structure encapsulates the routines needed to resolve a
+ * variable reference at runtime. Any variable specific state will typically
+ * be appended to this structure.
+ */
+
+typedef struct Tcl_ResolvedVarInfo {
+ Tcl_ResolveRuntimeVarProc *fetchProc;
+ Tcl_ResolveVarDeleteProc *deleteProc;
+} Tcl_ResolvedVarInfo;
+
+typedef int (Tcl_ResolveCompiledVarProc)(Tcl_Interp *interp,
+ CONST84 char *name, int length, Tcl_Namespace *context,
+ Tcl_ResolvedVarInfo **rPtr);
+
+typedef int (Tcl_ResolveVarProc)(Tcl_Interp *interp, CONST84 char *name,
+ Tcl_Namespace *context, int flags, Tcl_Var *rPtr);
+
+typedef int (Tcl_ResolveCmdProc)(Tcl_Interp *interp, CONST84 char *name,
+ Tcl_Namespace *context, int flags, Tcl_Command *rPtr);
+
+typedef struct Tcl_ResolverInfo {
+ Tcl_ResolveCmdProc *cmdResProc;
+ /* Procedure handling command name
+ * resolution. */
+ Tcl_ResolveVarProc *varResProc;
+ /* Procedure handling variable name resolution
+ * for variables that can only be handled at
+ * runtime. */
+ Tcl_ResolveCompiledVarProc *compiledVarResProc;
+ /* Procedure handling variable name resolution
+ * at compile time. */
+} Tcl_ResolverInfo;
+
+/*
+ * This flag bit should not interfere with TCL_GLOBAL_ONLY,
+ * TCL_NAMESPACE_ONLY, or TCL_LEAVE_ERR_MSG; it signals that the variable
+ * lookup is performed for upvar (or similar) purposes, with slightly
+ * different rules:
+ * - Bug #696893 - variable is either proc-local or in the current
+ * namespace; never follow the second (global) resolution path
+ * - Bug #631741 - do not use special namespace or interp resolvers
+ *
+ * It should also not collide with the (deprecated) TCL_PARSE_PART1 flag
+ * (Bug #835020)
+ */
+
+#define TCL_AVOID_RESOLVERS 0x40000
+
+/*
+ *----------------------------------------------------------------
+ * Data structures related to namespaces.
+ *----------------------------------------------------------------
+ */
+
+typedef struct Tcl_Ensemble Tcl_Ensemble;
+typedef struct NamespacePathEntry NamespacePathEntry;
+
+/*
+ * Special hashtable for variables: this is just a Tcl_HashTable with an nsPtr
+ * field added at the end: in this way variables can find their namespace
+ * without having to copy a pointer in their struct: they can access it via
+ * their hPtr->tablePtr.
+ */
+
+typedef struct TclVarHashTable {
+ Tcl_HashTable table;
+ struct Namespace *nsPtr;
+} TclVarHashTable;
+
+/*
+ * This is for itcl - it likes to search our varTables directly :(
+ */
+
+#define TclVarHashFindVar(tablePtr, key) \
+ TclVarHashCreateVar((tablePtr), (key), NULL)
+
+/*
+ * Define this to reduce the amount of space that the average namespace
+ * consumes by only allocating the table of child namespaces when necessary.
+ * Defining it breaks compatibility for Tcl extensions (e.g., itcl) which
+ * reach directly into the Namespace structure.
+ */
+
+#undef BREAK_NAMESPACE_COMPAT
+
+/*
+ * The structure below defines a namespace.
+ * Note: the first five fields must match exactly the fields in a
+ * Tcl_Namespace structure (see tcl.h). If you change one, be sure to change
+ * the other.
+ */
+
+typedef struct Namespace {
+ char *name; /* The namespace's simple (unqualified) name.
+ * This contains no ::'s. The name of the
+ * global namespace is "" although "::" is an
+ * synonym. */
+ char *fullName; /* The namespace's fully qualified name. This
+ * starts with ::. */
+ ClientData clientData; /* An arbitrary value associated with this
+ * namespace. */
+ Tcl_NamespaceDeleteProc *deleteProc;
+ /* Procedure invoked when deleting the
+ * namespace to, e.g., free clientData. */
+ struct Namespace *parentPtr;/* Points to the namespace that contains this
+ * one. NULL if this is the global
+ * namespace. */
+#ifndef BREAK_NAMESPACE_COMPAT
+ Tcl_HashTable childTable; /* Contains any child namespaces. Indexed by
+ * strings; values have type (Namespace *). */
+#else
+ Tcl_HashTable *childTablePtr;
+ /* Contains any child namespaces. Indexed by
+ * strings; values have type (Namespace *). If
+ * NULL, there are no children. */
+#endif
+ long nsId; /* Unique id for the namespace. */
+ Tcl_Interp *interp; /* The interpreter containing this
+ * namespace. */
+ int flags; /* OR-ed combination of the namespace status
+ * flags NS_DYING and NS_DEAD listed below. */
+ int activationCount; /* Number of "activations" or active call
+ * frames for this namespace that are on the
+ * Tcl call stack. The namespace won't be
+ * freed until activationCount becomes zero. */
+ int refCount; /* Count of references by namespaceName
+ * objects. The namespace can't be freed until
+ * refCount becomes zero. */
+ Tcl_HashTable cmdTable; /* Contains all the commands currently
+ * registered in the namespace. Indexed by
+ * strings; values have type (Command *).
+ * Commands imported by Tcl_Import have
+ * Command structures that point (via an
+ * ImportedCmdRef structure) to the Command
+ * structure in the source namespace's command
+ * table. */
+ TclVarHashTable varTable; /* Contains all the (global) variables
+ * currently in this namespace. Indexed by
+ * strings; values have type (Var *). */
+ char **exportArrayPtr; /* Points to an array of string patterns
+ * specifying which commands are exported. A
+ * pattern may include "string match" style
+ * wildcard characters to specify multiple
+ * commands; however, no namespace qualifiers
+ * are allowed. NULL if no export patterns are
+ * registered. */
+ int numExportPatterns; /* Number of export patterns currently
+ * registered using "namespace export". */
+ int maxExportPatterns; /* Mumber of export patterns for which space
+ * is currently allocated. */
+ int cmdRefEpoch; /* Incremented if a newly added command
+ * shadows a command for which this namespace
+ * has already cached a Command* pointer; this
+ * causes all its cached Command* pointers to
+ * be invalidated. */
+ int resolverEpoch; /* Incremented whenever (a) the name
+ * resolution rules change for this namespace
+ * or (b) a newly added command shadows a
+ * command that is compiled to bytecodes. This
+ * invalidates all byte codes compiled in the
+ * namespace, causing the code to be
+ * recompiled under the new rules.*/
+ Tcl_ResolveCmdProc *cmdResProc;
+ /* If non-null, this procedure overrides the
+ * usual command resolution mechanism in Tcl.
+ * This procedure is invoked within
+ * Tcl_FindCommand to resolve all command
+ * references within the namespace. */
+ Tcl_ResolveVarProc *varResProc;
+ /* If non-null, this procedure overrides the
+ * usual variable resolution mechanism in Tcl.
+ * This procedure is invoked within
+ * Tcl_FindNamespaceVar to resolve all
+ * variable references within the namespace at
+ * runtime. */
+ Tcl_ResolveCompiledVarProc *compiledVarResProc;
+ /* If non-null, this procedure overrides the
+ * usual variable resolution mechanism in Tcl.
+ * This procedure is invoked within
+ * LookupCompiledLocal to resolve variable
+ * references within the namespace at compile
+ * time. */
+ int exportLookupEpoch; /* Incremented whenever a command is added to
+ * a namespace, removed from a namespace or
+ * the exports of a namespace are changed.
+ * Allows TIP#112-driven command lists to be
+ * validated efficiently. */
+ Tcl_Ensemble *ensembles; /* List of structures that contain the details
+ * of the ensembles that are implemented on
+ * top of this namespace. */
+ Tcl_Obj *unknownHandlerPtr; /* A script fragment to be used when command
+ * resolution in this namespace fails. TIP
+ * 181. */
+ int commandPathLength; /* The length of the explicit path. */
+ NamespacePathEntry *commandPathArray;
+ /* The explicit path of the namespace as an
+ * array. */
+ NamespacePathEntry *commandPathSourceList;
+ /* Linked list of path entries that point to
+ * this namespace. */
+ Tcl_NamespaceDeleteProc *earlyDeleteProc;
+ /* Just like the deleteProc field (and called
+ * with the same clientData) but called at the
+ * start of the deletion process, so there is
+ * a chance for code to do stuff inside the
+ * namespace before deletion completes. */
+} Namespace;
+
+/*
+ * An entry on a namespace's command resolution path.
+ */
+
+struct NamespacePathEntry {
+ Namespace *nsPtr; /* What does this path entry point to? If it
+ * is NULL, this path entry points is
+ * redundant and should be skipped. */
+ Namespace *creatorNsPtr; /* Where does this path entry point from? This
+ * allows for efficient invalidation of
+ * references when the path entry's target
+ * updates its current list of defined
+ * commands. */
+ NamespacePathEntry *prevPtr, *nextPtr;
+ /* Linked list pointers or NULL at either end
+ * of the list that hangs off Namespace's
+ * commandPathSourceList field. */
+};
+
+/*
+ * Flags used to represent the status of a namespace:
+ *
+ * NS_DYING - 1 means Tcl_DeleteNamespace has been called to delete the
+ * namespace but there are still active call frames on the Tcl
+ * stack that refer to the namespace. When the last call frame
+ * referring to it has been popped, it's variables and command
+ * will be destroyed and it will be marked "dead" (NS_DEAD). The
+ * namespace can no longer be looked up by name.
+ * NS_DEAD - 1 means Tcl_DeleteNamespace has been called to delete the
+ * namespace and no call frames still refer to it. Its variables
+ * and command have already been destroyed. This bit allows the
+ * namespace resolution code to recognize that the namespace is
+ * "deleted". When the last namespaceName object in any byte code
+ * unit that refers to the namespace has been freed (i.e., when
+ * the namespace's refCount is 0), the namespace's storage will
+ * be freed.
+ * NS_KILLED - 1 means that TclTeardownNamespace has already been called on
+ * this namespace and it should not be called again [Bug 1355942]
+ * NS_SUPPRESS_COMPILATION -
+ * Marks the commands in this namespace for not being compiled,
+ * forcing them to be looked up every time.
+ */
+
+#define NS_DYING 0x01
+#define NS_DEAD 0x02
+#define NS_KILLED 0x04
+#define NS_SUPPRESS_COMPILATION 0x08
+
+/*
+ * Flags passed to TclGetNamespaceForQualName:
+ *
+ * TCL_GLOBAL_ONLY - (see tcl.h) Look only in the global ns.
+ * TCL_NAMESPACE_ONLY - (see tcl.h) Look only in the context ns.
+ * TCL_CREATE_NS_IF_UNKNOWN - Create unknown namespaces.
+ * TCL_FIND_ONLY_NS - The name sought is a namespace name.
+ */
+
+#define TCL_CREATE_NS_IF_UNKNOWN 0x800
+#define TCL_FIND_ONLY_NS 0x1000
+
+/*
+ * The client data for an ensemble command. This consists of the table of
+ * commands that are actually exported by the namespace, and an epoch counter
+ * that, combined with the exportLookupEpoch field of the namespace structure,
+ * defines whether the table contains valid data or will need to be recomputed
+ * next time the ensemble command is called.
+ */
+
+typedef struct EnsembleConfig {
+ Namespace *nsPtr; /* The namespace backing this ensemble up. */
+ Tcl_Command token; /* The token for the command that provides
+ * ensemble support for the namespace, or NULL
+ * if the command has been deleted (or never
+ * existed; the global namespace never has an
+ * ensemble command.) */
+ int epoch; /* The epoch at which this ensemble's table of
+ * exported commands is valid. */
+ char **subcommandArrayPtr; /* Array of ensemble subcommand names. At all
+ * consistent points, this will have the same
+ * number of entries as there are entries in
+ * the subcommandTable hash. */
+ Tcl_HashTable subcommandTable;
+ /* Hash table of ensemble subcommand names,
+ * which are its keys so this also provides
+ * the storage management for those subcommand
+ * names. The contents of the entry values are
+ * object version the prefix lists to use when
+ * substituting for the command/subcommand to
+ * build the ensemble implementation command.
+ * Has to be stored here as well as in
+ * subcommandDict because that field is NULL
+ * when we are deriving the ensemble from the
+ * namespace exports list. FUTURE WORK: use
+ * object hash table here. */
+ struct EnsembleConfig *next;/* The next ensemble in the linked list of
+ * ensembles associated with a namespace. If
+ * this field points to this ensemble, the
+ * structure has already been unlinked from
+ * all lists, and cannot be found by scanning
+ * the list from the namespace's ensemble
+ * field. */
+ int flags; /* ORed combo of TCL_ENSEMBLE_PREFIX,
+ * ENSEMBLE_DEAD and ENSEMBLE_COMPILE. */
+
+ /* OBJECT FIELDS FOR ENSEMBLE CONFIGURATION */
+
+ Tcl_Obj *subcommandDict; /* Dictionary providing mapping from
+ * subcommands to their implementing command
+ * prefixes, or NULL if we are to build the
+ * map automatically from the namespace
+ * exports. */
+ Tcl_Obj *subcmdList; /* List of commands that this ensemble
+ * actually provides, and whose implementation
+ * will be built using the subcommandDict (if
+ * present and defined) and by simple mapping
+ * to the namespace otherwise. If NULL,
+ * indicates that we are using the (dynamic)
+ * list of currently exported commands. */
+ Tcl_Obj *unknownHandler; /* Script prefix used to handle the case when
+ * no match is found (according to the rule
+ * defined by flag bit TCL_ENSEMBLE_PREFIX) or
+ * NULL to use the default error-generating
+ * behaviour. The script execution gets all
+ * the arguments to the ensemble command
+ * (including objv[0]) and will have the
+ * results passed directly back to the caller
+ * (including the error code) unless the code
+ * is TCL_CONTINUE in which case the
+ * subcommand will be reparsed by the ensemble
+ * core, presumably because the ensemble
+ * itself has been updated. */
+ Tcl_Obj *parameterList; /* List of ensemble parameter names. */
+ int numParameters; /* Cached number of parameters. This is either
+ * 0 (if the parameterList field is NULL) or
+ * the length of the list in the parameterList
+ * field. */
+} EnsembleConfig;
+
+/*
+ * Various bits for the EnsembleConfig.flags field.
+ */
+
+#define ENSEMBLE_DEAD 0x1 /* Flag value to say that the ensemble is dead
+ * and on its way out. */
+#define ENSEMBLE_COMPILE 0x4 /* Flag to enable bytecode compilation of an
+ * ensemble. */
+
+/*
+ *----------------------------------------------------------------
+ * Data structures related to variables. These are used primarily in tclVar.c
+ *----------------------------------------------------------------
+ */
+
+/*
+ * The following structure defines a variable trace, which is used to invoke a
+ * specific C procedure whenever certain operations are performed on a
+ * variable.
+ */
+
+typedef struct VarTrace {
+ Tcl_VarTraceProc *traceProc;/* Procedure to call when operations given by
+ * flags are performed on variable. */
+ ClientData clientData; /* Argument to pass to proc. */
+ int flags; /* What events the trace procedure is
+ * interested in: OR-ed combination of
+ * TCL_TRACE_READS, TCL_TRACE_WRITES,
+ * TCL_TRACE_UNSETS and TCL_TRACE_ARRAY. */
+ struct VarTrace *nextPtr; /* Next in list of traces associated with a
+ * particular variable. */
+} VarTrace;
+
+/*
+ * The following structure defines a command trace, which is used to invoke a
+ * specific C procedure whenever certain operations are performed on a
+ * command.
+ */
+
+typedef struct CommandTrace {
+ Tcl_CommandTraceProc *traceProc;
+ /* Procedure to call when operations given by
+ * flags are performed on command. */
+ ClientData clientData; /* Argument to pass to proc. */
+ int flags; /* What events the trace procedure is
+ * interested in: OR-ed combination of
+ * TCL_TRACE_RENAME, TCL_TRACE_DELETE. */
+ struct CommandTrace *nextPtr;
+ /* Next in list of traces associated with a
+ * particular command. */
+ int refCount; /* Used to ensure this structure is not
+ * deleted too early. Keeps track of how many
+ * pieces of code have a pointer to this
+ * structure. */
+} CommandTrace;
+
+/*
+ * When a command trace is active (i.e. its associated procedure is executing)
+ * one of the following structures is linked into a list associated with the
+ * command's interpreter. The information in the structure is needed in order
+ * for Tcl to behave reasonably if traces are deleted while traces are active.
+ */
+
+typedef struct ActiveCommandTrace {
+ struct Command *cmdPtr; /* Command that's being traced. */
+ struct ActiveCommandTrace *nextPtr;
+ /* Next in list of all active command traces
+ * for the interpreter, or NULL if no more. */
+ CommandTrace *nextTracePtr; /* Next trace to check after current trace
+ * procedure returns; if this trace gets
+ * deleted, must update pointer to avoid using
+ * free'd memory. */
+ int reverseScan; /* Boolean set true when traces are scanning
+ * in reverse order. */
+} ActiveCommandTrace;
+
+/*
+ * When a variable trace is active (i.e. its associated procedure is
+ * executing) one of the following structures is linked into a list associated
+ * with the variable's interpreter. The information in the structure is needed
+ * in order for Tcl to behave reasonably if traces are deleted while traces
+ * are active.
+ */
+
+typedef struct ActiveVarTrace {
+ struct Var *varPtr; /* Variable that's being traced. */
+ struct ActiveVarTrace *nextPtr;
+ /* Next in list of all active variable traces
+ * for the interpreter, or NULL if no more. */
+ VarTrace *nextTracePtr; /* Next trace to check after current trace
+ * procedure returns; if this trace gets
+ * deleted, must update pointer to avoid using
+ * free'd memory. */
+} ActiveVarTrace;
+
+/*
+ * The structure below defines a variable, which associates a string name with
+ * a Tcl_Obj value. These structures are kept in procedure call frames (for
+ * local variables recognized by the compiler) or in the heap (for global
+ * variables and any variable not known to the compiler). For each Var
+ * structure in the heap, a hash table entry holds the variable name and a
+ * pointer to the Var structure.
+ */
+
+typedef struct Var {
+ int flags; /* Miscellaneous bits of information about
+ * variable. See below for definitions. */
+ union {
+ Tcl_Obj *objPtr; /* The variable's object value. Used for
+ * scalar variables and array elements. */
+ TclVarHashTable *tablePtr;/* For array variables, this points to
+ * information about the hash table used to
+ * implement the associative array. Points to
+ * ckalloc-ed data. */
+ struct Var *linkPtr; /* If this is a global variable being referred
+ * to in a procedure, or a variable created by
+ * "upvar", this field points to the
+ * referenced variable's Var struct. */
+ } value;
+} Var;
+
+typedef struct VarInHash {
+ Var var;
+ int refCount; /* Counts number of active uses of this
+ * variable: 1 for the entry in the hash
+ * table, 1 for each additional variable whose
+ * linkPtr points here, 1 for each nested
+ * trace active on variable, and 1 if the
+ * variable is a namespace variable. This
+ * record can't be deleted until refCount
+ * becomes 0. */
+ Tcl_HashEntry entry; /* The hash table entry that refers to this
+ * variable. This is used to find the name of
+ * the variable and to delete it from its
+ * hashtable if it is no longer needed. It
+ * also holds the variable's name. */
+} VarInHash;
+
+/*
+ * Flag bits for variables. The first two (VAR_ARRAY and VAR_LINK) are
+ * mutually exclusive and give the "type" of the variable. If none is set,
+ * this is a scalar variable.
+ *
+ * VAR_ARRAY - 1 means this is an array variable rather than
+ * a scalar variable or link. The "tablePtr"
+ * field points to the array's hashtable for its
+ * elements.
+ * VAR_LINK - 1 means this Var structure contains a pointer
+ * to another Var structure that either has the
+ * real value or is itself another VAR_LINK
+ * pointer. Variables like this come about
+ * through "upvar" and "global" commands, or
+ * through references to variables in enclosing
+ * namespaces.
+ *
+ * Flags that indicate the type and status of storage; none is set for
+ * compiled local variables (Var structs).
+ *
+ * VAR_IN_HASHTABLE - 1 means this variable is in a hashtable and
+ * the Var structure is malloced. 0 if it is a
+ * local variable that was assigned a slot in a
+ * procedure frame by the compiler so the Var
+ * storage is part of the call frame.
+ * VAR_DEAD_HASH 1 means that this var's entry in the hashtable
+ * has already been deleted.
+ * VAR_ARRAY_ELEMENT - 1 means that this variable is an array
+ * element, so it is not legal for it to be an
+ * array itself (the VAR_ARRAY flag had better
+ * not be set).
+ * VAR_NAMESPACE_VAR - 1 means that this variable was declared as a
+ * namespace variable. This flag ensures it
+ * persists until its namespace is destroyed or
+ * until the variable is unset; it will persist
+ * even if it has not been initialized and is
+ * marked undefined. The variable's refCount is
+ * incremented to reflect the "reference" from
+ * its namespace.
+ *
+ * Flag values relating to the variable's trace and search status.
+ *
+ * VAR_TRACED_READ
+ * VAR_TRACED_WRITE
+ * VAR_TRACED_UNSET
+ * VAR_TRACED_ARRAY
+ * VAR_TRACE_ACTIVE - 1 means that trace processing is currently
+ * underway for a read or write access, so new
+ * read or write accesses should not cause trace
+ * procedures to be called and the variable can't
+ * be deleted.
+ * VAR_SEARCH_ACTIVE
+ *
+ * The following additional flags are used with the CompiledLocal type defined
+ * below:
+ *
+ * VAR_ARGUMENT - 1 means that this variable holds a procedure
+ * argument.
+ * VAR_TEMPORARY - 1 if the local variable is an anonymous
+ * temporary variable. Temporaries have a NULL
+ * name.
+ * VAR_RESOLVED - 1 if name resolution has been done for this
+ * variable.
+ * VAR_IS_ARGS 1 if this variable is the last argument and is
+ * named "args".
+ */
+
+/*
+ * FLAGS RENUMBERED: everything breaks already, make things simpler.
+ *
+ * IMPORTANT: skip the values 0x10, 0x20, 0x40, 0x800 corresponding to
+ * TCL_TRACE_(READS/WRITES/UNSETS/ARRAY): makes code simpler in tclTrace.c
+ *
+ * Keep the flag values for VAR_ARGUMENT and VAR_TEMPORARY so that old values
+ * in precompiled scripts keep working.
+ */
+
+/* Type of value (0 is scalar) */
+#define VAR_ARRAY 0x1
+#define VAR_LINK 0x2
+
+/* Type of storage (0 is compiled local) */
+#define VAR_IN_HASHTABLE 0x4
+#define VAR_DEAD_HASH 0x8
+#define VAR_ARRAY_ELEMENT 0x1000
+#define VAR_NAMESPACE_VAR 0x80 /* KEEP OLD VALUE for Itcl */
+
+#define VAR_ALL_HASH \
+ (VAR_IN_HASHTABLE|VAR_DEAD_HASH|VAR_NAMESPACE_VAR|VAR_ARRAY_ELEMENT)
+
+/* Trace and search state. */
+
+#define VAR_TRACED_READ 0x10 /* TCL_TRACE_READS */
+#define VAR_TRACED_WRITE 0x20 /* TCL_TRACE_WRITES */
+#define VAR_TRACED_UNSET 0x40 /* TCL_TRACE_UNSETS */
+#define VAR_TRACED_ARRAY 0x800 /* TCL_TRACE_ARRAY */
+#define VAR_TRACE_ACTIVE 0x2000
+#define VAR_SEARCH_ACTIVE 0x4000
+#define VAR_ALL_TRACES \
+ (VAR_TRACED_READ|VAR_TRACED_WRITE|VAR_TRACED_ARRAY|VAR_TRACED_UNSET)
+
+/* Special handling on initialisation (only CompiledLocal). */
+#define VAR_ARGUMENT 0x100 /* KEEP OLD VALUE! See tclProc.c */
+#define VAR_TEMPORARY 0x200 /* KEEP OLD VALUE! See tclProc.c */
+#define VAR_IS_ARGS 0x400
+#define VAR_RESOLVED 0x8000
+
+/*
+ * Macros to ensure that various flag bits are set properly for variables.
+ * The ANSI C "prototypes" for these macros are:
+ *
+ * MODULE_SCOPE void TclSetVarScalar(Var *varPtr);
+ * MODULE_SCOPE void TclSetVarArray(Var *varPtr);
+ * MODULE_SCOPE void TclSetVarLink(Var *varPtr);
+ * MODULE_SCOPE void TclSetVarArrayElement(Var *varPtr);
+ * MODULE_SCOPE void TclSetVarUndefined(Var *varPtr);
+ * MODULE_SCOPE void TclClearVarUndefined(Var *varPtr);
+ */
+
+#define TclSetVarScalar(varPtr) \
+ (varPtr)->flags &= ~(VAR_ARRAY|VAR_LINK)
+
+#define TclSetVarArray(varPtr) \
+ (varPtr)->flags = ((varPtr)->flags & ~VAR_LINK) | VAR_ARRAY
+
+#define TclSetVarLink(varPtr) \
+ (varPtr)->flags = ((varPtr)->flags & ~VAR_ARRAY) | VAR_LINK
+
+#define TclSetVarArrayElement(varPtr) \
+ (varPtr)->flags = ((varPtr)->flags & ~VAR_ARRAY) | VAR_ARRAY_ELEMENT
+
+#define TclSetVarUndefined(varPtr) \
+ (varPtr)->flags &= ~(VAR_ARRAY|VAR_LINK);\
+ (varPtr)->value.objPtr = NULL
+
+#define TclClearVarUndefined(varPtr)
+
+#define TclSetVarTraceActive(varPtr) \
+ (varPtr)->flags |= VAR_TRACE_ACTIVE
+
+#define TclClearVarTraceActive(varPtr) \
+ (varPtr)->flags &= ~VAR_TRACE_ACTIVE
+
+#define TclSetVarNamespaceVar(varPtr) \
+ if (!TclIsVarNamespaceVar(varPtr)) {\
+ (varPtr)->flags |= VAR_NAMESPACE_VAR;\
+ if (TclIsVarInHash(varPtr)) {\
+ ((VarInHash *)(varPtr))->refCount++;\
+ }\
+ }
+
+#define TclClearVarNamespaceVar(varPtr) \
+ if (TclIsVarNamespaceVar(varPtr)) {\
+ (varPtr)->flags &= ~VAR_NAMESPACE_VAR;\
+ if (TclIsVarInHash(varPtr)) {\
+ ((VarInHash *)(varPtr))->refCount--;\
+ }\
+ }
+
+/*
+ * Macros to read various flag bits of variables.
+ * The ANSI C "prototypes" for these macros are:
+ *
+ * MODULE_SCOPE int TclIsVarScalar(Var *varPtr);
+ * MODULE_SCOPE int TclIsVarLink(Var *varPtr);
+ * MODULE_SCOPE int TclIsVarArray(Var *varPtr);
+ * MODULE_SCOPE int TclIsVarUndefined(Var *varPtr);
+ * MODULE_SCOPE int TclIsVarArrayElement(Var *varPtr);
+ * MODULE_SCOPE int TclIsVarTemporary(Var *varPtr);
+ * MODULE_SCOPE int TclIsVarArgument(Var *varPtr);
+ * MODULE_SCOPE int TclIsVarResolved(Var *varPtr);
+ */
+
+#define TclIsVarScalar(varPtr) \
+ !((varPtr)->flags & (VAR_ARRAY|VAR_LINK))
+
+#define TclIsVarLink(varPtr) \
+ ((varPtr)->flags & VAR_LINK)
+
+#define TclIsVarArray(varPtr) \
+ ((varPtr)->flags & VAR_ARRAY)
+
+#define TclIsVarUndefined(varPtr) \
+ ((varPtr)->value.objPtr == NULL)
+
+#define TclIsVarArrayElement(varPtr) \
+ ((varPtr)->flags & VAR_ARRAY_ELEMENT)
+
+#define TclIsVarNamespaceVar(varPtr) \
+ ((varPtr)->flags & VAR_NAMESPACE_VAR)
+
+#define TclIsVarTemporary(varPtr) \
+ ((varPtr)->flags & VAR_TEMPORARY)
+
+#define TclIsVarArgument(varPtr) \
+ ((varPtr)->flags & VAR_ARGUMENT)
+
+#define TclIsVarResolved(varPtr) \
+ ((varPtr)->flags & VAR_RESOLVED)
+
+#define TclIsVarTraceActive(varPtr) \
+ ((varPtr)->flags & VAR_TRACE_ACTIVE)
+
+#define TclIsVarTraced(varPtr) \
+ ((varPtr)->flags & VAR_ALL_TRACES)
+
+#define TclIsVarInHash(varPtr) \
+ ((varPtr)->flags & VAR_IN_HASHTABLE)
+
+#define TclIsVarDeadHash(varPtr) \
+ ((varPtr)->flags & VAR_DEAD_HASH)
+
+#define TclGetVarNsPtr(varPtr) \
+ (TclIsVarInHash(varPtr) \
+ ? ((TclVarHashTable *) ((((VarInHash *) (varPtr))->entry.tablePtr)))->nsPtr \
+ : NULL)
+
+#define VarHashRefCount(varPtr) \
+ ((VarInHash *) (varPtr))->refCount
+
+/*
+ * Macros for direct variable access by TEBC.
+ */
+
+#define TclIsVarDirectReadable(varPtr) \
+ ( !((varPtr)->flags & (VAR_ARRAY|VAR_LINK|VAR_TRACED_READ)) \
+ && (varPtr)->value.objPtr)
+
+#define TclIsVarDirectWritable(varPtr) \
+ !((varPtr)->flags & (VAR_ARRAY|VAR_LINK|VAR_TRACED_WRITE|VAR_DEAD_HASH))
+
+#define TclIsVarDirectUnsettable(varPtr) \
+ !((varPtr)->flags & (VAR_ARRAY|VAR_LINK|VAR_TRACED_READ|VAR_TRACED_WRITE|VAR_TRACED_UNSET|VAR_DEAD_HASH))
+
+#define TclIsVarDirectModifyable(varPtr) \
+ ( !((varPtr)->flags & (VAR_ARRAY|VAR_LINK|VAR_TRACED_READ|VAR_TRACED_WRITE)) \
+ && (varPtr)->value.objPtr)
+
+#define TclIsVarDirectReadable2(varPtr, arrayPtr) \
+ (TclIsVarDirectReadable(varPtr) &&\
+ (!(arrayPtr) || !((arrayPtr)->flags & VAR_TRACED_READ)))
+
+#define TclIsVarDirectWritable2(varPtr, arrayPtr) \
+ (TclIsVarDirectWritable(varPtr) &&\
+ (!(arrayPtr) || !((arrayPtr)->flags & VAR_TRACED_WRITE)))
+
+#define TclIsVarDirectModifyable2(varPtr, arrayPtr) \
+ (TclIsVarDirectModifyable(varPtr) &&\
+ (!(arrayPtr) || !((arrayPtr)->flags & (VAR_TRACED_READ|VAR_TRACED_WRITE))))
+
+/*
+ *----------------------------------------------------------------
+ * Data structures related to procedures. These are used primarily in
+ * tclProc.c, tclCompile.c, and tclExecute.c.
+ *----------------------------------------------------------------
+ */
+
+/*
+ * Forward declaration to prevent an error when the forward reference to
+ * Command is encountered in the Proc and ImportRef types declared below.
+ */
+
+struct Command;
+
+/*
+ * The variable-length structure below describes a local variable of a
+ * procedure that was recognized by the compiler. These variables have a name,
+ * an element in the array of compiler-assigned local variables in the
+ * procedure's call frame, and various other items of information. If the
+ * local variable is a formal argument, it may also have a default value. The
+ * compiler can't recognize local variables whose names are expressions (these
+ * names are only known at runtime when the expressions are evaluated) or
+ * local variables that are created as a result of an "upvar" or "uplevel"
+ * command. These other local variables are kept separately in a hash table in
+ * the call frame.
+ */
+
+typedef struct CompiledLocal {
+ struct CompiledLocal *nextPtr;
+ /* Next compiler-recognized local variable for
+ * this procedure, or NULL if this is the last
+ * local. */
+ int nameLength; /* The number of characters in local
+ * variable's name. Used to speed up variable
+ * lookups. */
+ int frameIndex; /* Index in the array of compiler-assigned
+ * variables in the procedure call frame. */
+ int flags; /* Flag bits for the local variable. Same as
+ * the flags for the Var structure above,
+ * although only VAR_ARGUMENT, VAR_TEMPORARY,
+ * and VAR_RESOLVED make sense. */
+ Tcl_Obj *defValuePtr; /* Pointer to the default value of an
+ * argument, if any. NULL if not an argument
+ * or, if an argument, no default value. */
+ Tcl_ResolvedVarInfo *resolveInfo;
+ /* Customized variable resolution info
+ * supplied by the Tcl_ResolveCompiledVarProc
+ * associated with a namespace. Each variable
+ * is marked by a unique ClientData tag during
+ * compilation, and that same tag is used to
+ * find the variable at runtime. */
+ char name[1]; /* Name of the local variable starts here. If
+ * the name is NULL, this will just be '\0'.
+ * The actual size of this field will be large
+ * enough to hold the name. MUST BE THE LAST
+ * FIELD IN THE STRUCTURE! */
+} CompiledLocal;
+
+/*
+ * The structure below defines a command procedure, which consists of a
+ * collection of Tcl commands plus information about arguments and other local
+ * variables recognized at compile time.
+ */
+
+typedef struct Proc {
+ struct Interp *iPtr; /* Interpreter for which this command is
+ * defined. */
+ int refCount; /* Reference count: 1 if still present in
+ * command table plus 1 for each call to the
+ * procedure that is currently active. This
+ * structure can be freed when refCount
+ * becomes zero. */
+ struct Command *cmdPtr; /* Points to the Command structure for this
+ * procedure. This is used to get the
+ * namespace in which to execute the
+ * procedure. */
+ Tcl_Obj *bodyPtr; /* Points to the ByteCode object for
+ * procedure's body command. */
+ int numArgs; /* Number of formal parameters. */
+ int numCompiledLocals; /* Count of local variables recognized by the
+ * compiler including arguments and
+ * temporaries. */
+ CompiledLocal *firstLocalPtr;
+ /* Pointer to first of the procedure's
+ * compiler-allocated local variables, or NULL
+ * if none. The first numArgs entries in this
+ * list describe the procedure's formal
+ * arguments. */
+ CompiledLocal *lastLocalPtr;/* Pointer to the last allocated local
+ * variable or NULL if none. This has frame
+ * index (numCompiledLocals-1). */
+} Proc;
+
+/*
+ * The type of functions called to process errors found during the execution
+ * of a procedure (or lambda term or ...).
+ */
+
+typedef void (ProcErrorProc)(Tcl_Interp *interp, Tcl_Obj *procNameObj);
+
+/*
+ * The structure below defines a command trace. This is used to allow Tcl
+ * clients to find out whenever a command is about to be executed.
+ */
+
+typedef struct Trace {
+ int level; /* Only trace commands at nesting level less
+ * than or equal to this. */
+ Tcl_CmdObjTraceProc *proc; /* Procedure to call to trace command. */
+ ClientData clientData; /* Arbitrary value to pass to proc. */
+ struct Trace *nextPtr; /* Next in list of traces for this interp. */
+ int flags; /* Flags governing the trace - see
+ * Tcl_CreateObjTrace for details. */
+ Tcl_CmdObjTraceDeleteProc *delProc;
+ /* Procedure to call when trace is deleted. */
+} Trace;
+
+/*
+ * When an interpreter trace is active (i.e. its associated procedure is
+ * executing), one of the following structures is linked into a list
+ * associated with the interpreter. The information in the structure is needed
+ * in order for Tcl to behave reasonably if traces are deleted while traces
+ * are active.
+ */
+
+typedef struct ActiveInterpTrace {
+ struct ActiveInterpTrace *nextPtr;
+ /* Next in list of all active command traces
+ * for the interpreter, or NULL if no more. */
+ Trace *nextTracePtr; /* Next trace to check after current trace
+ * procedure returns; if this trace gets
+ * deleted, must update pointer to avoid using
+ * free'd memory. */
+ int reverseScan; /* Boolean set true when traces are scanning
+ * in reverse order. */
+} ActiveInterpTrace;
+
+/*
+ * Flag values designating types of execution traces. See tclTrace.c for
+ * related flag values.
+ *
+ * TCL_TRACE_ENTER_EXEC - triggers enter/enterstep traces.
+ * - passed to Tcl_CreateObjTrace to set up
+ * "enterstep" traces.
+ * TCL_TRACE_LEAVE_EXEC - triggers leave/leavestep traces.
+ * - passed to Tcl_CreateObjTrace to set up
+ * "leavestep" traces.
+ */
+
+#define TCL_TRACE_ENTER_EXEC 1
+#define TCL_TRACE_LEAVE_EXEC 2
+
+/*
+ * The structure below defines an entry in the assocData hash table which is
+ * associated with an interpreter. The entry contains a pointer to a function
+ * to call when the interpreter is deleted, and a pointer to a user-defined
+ * piece of data.
+ */
+
+typedef struct AssocData {
+ Tcl_InterpDeleteProc *proc; /* Proc to call when deleting. */
+ ClientData clientData; /* Value to pass to proc. */
+} AssocData;
+
+/*
+ * The structure below defines a call frame. A call frame defines a naming
+ * context for a procedure call: its local naming scope (for local variables)
+ * and its global naming scope (a namespace, perhaps the global :: namespace).
+ * A call frame can also define the naming context for a namespace eval or
+ * namespace inscope command: the namespace in which the command's code should
+ * execute. The Tcl_CallFrame structures exist only while procedures or
+ * namespace eval/inscope's are being executed, and provide a kind of Tcl call
+ * stack.
+ *
+ * WARNING!! The structure definition must be kept consistent with the
+ * Tcl_CallFrame structure in tcl.h. If you change one, change the other.
+ */
+
+/*
+ * Will be grown to contain: pointers to the varnames (allocated at the end),
+ * plus the init values for each variable (suitable to be memcopied on init)
+ */
+
+typedef struct LocalCache {
+ int refCount;
+ int numVars;
+ Tcl_Obj *varName0;
+} LocalCache;
+
+#define localName(framePtr, i) \
+ ((&((framePtr)->localCachePtr->varName0))[(i)])
+
+MODULE_SCOPE void TclFreeLocalCache(Tcl_Interp *interp,
+ LocalCache *localCachePtr);
+
+typedef struct CallFrame {
+ Namespace *nsPtr; /* Points to the namespace used to resolve
+ * commands and global variables. */
+ int isProcCallFrame; /* If 0, the frame was pushed to execute a
+ * namespace command and var references are
+ * treated as references to namespace vars;
+ * varTablePtr and compiledLocals are ignored.
+ * If FRAME_IS_PROC is set, the frame was
+ * pushed to execute a Tcl procedure and may
+ * have local vars. */
+ int objc; /* This and objv below describe the arguments
+ * for this procedure call. */
+ Tcl_Obj *const *objv; /* Array of argument objects. */
+ struct CallFrame *callerPtr;
+ /* Value of interp->framePtr when this
+ * procedure was invoked (i.e. next higher in
+ * stack of all active procedures). */
+ struct CallFrame *callerVarPtr;
+ /* Value of interp->varFramePtr when this
+ * procedure was invoked (i.e. determines
+ * variable scoping within caller). Same as
+ * callerPtr unless an "uplevel" command or
+ * something equivalent was active in the
+ * caller). */
+ int level; /* Level of this procedure, for "uplevel"
+ * purposes (i.e. corresponds to nesting of
+ * callerVarPtr's, not callerPtr's). 1 for
+ * outermost procedure, 0 for top-level. */
+ Proc *procPtr; /* Points to the structure defining the called
+ * procedure. Used to get information such as
+ * the number of compiled local variables
+ * (local variables assigned entries ["slots"]
+ * in the compiledLocals array below). */
+ TclVarHashTable *varTablePtr;
+ /* Hash table containing local variables not
+ * recognized by the compiler, or created at
+ * execution time through, e.g., upvar.
+ * Initially NULL and created if needed. */
+ int numCompiledLocals; /* Count of local variables recognized by the
+ * compiler including arguments. */
+ Var *compiledLocals; /* Points to the array of local variables
+ * recognized by the compiler. The compiler
+ * emits code that refers to these variables
+ * using an index into this array. */
+ ClientData clientData; /* Pointer to some context that is used by
+ * object systems. The meaning of the contents
+ * of this field is defined by the code that
+ * sets it, and it should only ever be set by
+ * the code that is pushing the frame. In that
+ * case, the code that sets it should also
+ * have some means of discovering what the
+ * meaning of the value is, which we do not
+ * specify. */
+ LocalCache *localCachePtr;
+ Tcl_Obj *tailcallPtr;
+ /* NULL if no tailcall is scheduled */
+} CallFrame;
+
+#define FRAME_IS_PROC 0x1
+#define FRAME_IS_LAMBDA 0x2
+#define FRAME_IS_METHOD 0x4 /* The frame is a method body, and the frame's
+ * clientData field contains a CallContext
+ * reference. Part of TIP#257. */
+#define FRAME_IS_OO_DEFINE 0x8 /* The frame is part of the inside workings of
+ * the [oo::define] command; the clientData
+ * field contains an Object reference that has
+ * been confirmed to refer to a class. Part of
+ * TIP#257. */
+
+/*
+ * TIP #280
+ * The structure below defines a command frame. A command frame provides
+ * location information for all commands executing a tcl script (source, eval,
+ * uplevel, procedure bodies, ...). The runtime structure essentially contains
+ * the stack trace as it would be if the currently executing command were to
+ * throw an error.
+ *
+ * For commands where it makes sense it refers to the associated CallFrame as
+ * well.
+ *
+ * The structures are chained in a single list, with the top of the stack
+ * anchored in the Interp structure.
+ *
+ * Instances can be allocated on the C stack, or the heap, the former making
+ * cleanup a bit simpler.
+ */
+
+typedef struct CmdFrame {
+ /*
+ * General data. Always available.
+ */
+
+ int type; /* Values see below. */
+ int level; /* Number of frames in stack, prevent O(n)
+ * scan of list. */
+ int *line; /* Lines the words of the command start on. */
+ int nline;
+ CallFrame *framePtr; /* Procedure activation record, may be
+ * NULL. */
+ struct CmdFrame *nextPtr; /* Link to calling frame. */
+ /*
+ * Data needed for Eval vs TEBC
+ *
+ * EXECUTION CONTEXTS and usage of CmdFrame
+ *
+ * Field TEBC EvalEx
+ * ======= ==== ======
+ * level yes yes
+ * type BC/PREBC SRC/EVAL
+ * line0 yes yes
+ * framePtr yes yes
+ * ======= ==== ======
+ *
+ * ======= ==== ========= union data
+ * line1 - yes
+ * line3 - yes
+ * path - yes
+ * ------- ---- ------
+ * codePtr yes -
+ * pc yes -
+ * ======= ==== ======
+ *
+ * ======= ==== ========= union cmd
+ * str.cmd yes yes
+ * str.len yes yes
+ * ------- ---- ------
+ */
+
+ union {
+ struct {
+ Tcl_Obj *path; /* Path of the sourced file the command is
+ * in. */
+ } eval;
+ struct {
+ const void *codePtr;/* Byte code currently executed... */
+ const char *pc; /* ... and instruction pointer. */
+ } tebc;
+ } data;
+ Tcl_Obj *cmdObj;
+ const char *cmd; /* The executed command, if possible... */
+ int len; /* ... and its length. */
+ const struct CFWordBC *litarg;
+ /* Link to set of literal arguments which have
+ * ben pushed on the lineLABCPtr stack by
+ * TclArgumentBCEnter(). These will be removed
+ * by TclArgumentBCRelease. */
+} CmdFrame;
+
+typedef struct CFWord {
+ CmdFrame *framePtr; /* CmdFrame to access. */
+ int word; /* Index of the word in the command. */
+ int refCount; /* Number of times the word is on the
+ * stack. */
+} CFWord;
+
+typedef struct CFWordBC {
+ CmdFrame *framePtr; /* CmdFrame to access. */
+ int pc; /* Instruction pointer of a command in
+ * ExtCmdLoc.loc[.] */
+ int word; /* Index of word in
+ * ExtCmdLoc.loc[cmd]->line[.] */
+ struct CFWordBC *prevPtr; /* Previous entry in stack for same Tcl_Obj. */
+ struct CFWordBC *nextPtr; /* Next entry for same command call. See
+ * CmdFrame litarg field for the list start. */
+ Tcl_Obj *obj; /* Back reference to hashtable key */
+} CFWordBC;
+
+/*
+ * Structure to record the locations of invisible continuation lines in
+ * literal scripts, as character offset from the beginning of the script. Both
+ * compiler and direct evaluator use this information to adjust their line
+ * counters when tracking through the script, because when it is invoked the
+ * continuation line marker as a whole has been removed already, meaning that
+ * the \n which was part of it is gone as well, breaking regular line
+ * tracking.
+ *
+ * These structures are allocated and filled by both the function
+ * TclSubstTokens() in the file "tclParse.c" and its caller TclEvalEx() in the
+ * file "tclBasic.c", and stored in the thread-global hashtable "lineCLPtr" in
+ * file "tclObj.c". They are used by the functions TclSetByteCodeFromAny() and
+ * TclCompileScript(), both found in the file "tclCompile.c". Their memory is
+ * released by the function TclFreeObj(), in the file "tclObj.c", and also by
+ * the function TclThreadFinalizeObjects(), in the same file.
+ */
+
+#define CLL_END (-1)
+
+typedef struct ContLineLoc {
+ int num; /* Number of entries in loc, not counting the
+ * final -1 marker entry. */
+ int loc[1]; /* Table of locations, as character offsets.
+ * The table is allocated as part of the
+ * structure, extending behind the nominal end
+ * of the structure. An entry containing the
+ * value -1 is put after the last location, as
+ * end-marker/sentinel. */
+} ContLineLoc;
+
+/*
+ * The following macros define the allowed values for the type field of the
+ * CmdFrame structure above. Some of the values occur only in the extended
+ * location data referenced via the 'baseLocPtr'.
+ *
+ * TCL_LOCATION_EVAL : Frame is for a script evaluated by EvalEx.
+ * TCL_LOCATION_BC : Frame is for bytecode.
+ * TCL_LOCATION_PREBC : Frame is for precompiled bytecode.
+ * TCL_LOCATION_SOURCE : Frame is for a script evaluated by EvalEx, from a
+ * sourced file.
+ * TCL_LOCATION_PROC : Frame is for bytecode of a procedure.
+ *
+ * A TCL_LOCATION_BC type in a frame can be overridden by _SOURCE and _PROC
+ * types, per the context of the byte code in execution.
+ */
+
+#define TCL_LOCATION_EVAL (0) /* Location in a dynamic eval script. */
+#define TCL_LOCATION_BC (2) /* Location in byte code. */
+#define TCL_LOCATION_PREBC (3) /* Location in precompiled byte code, no
+ * location. */
+#define TCL_LOCATION_SOURCE (4) /* Location in a file. */
+#define TCL_LOCATION_PROC (5) /* Location in a dynamic proc. */
+#define TCL_LOCATION_LAST (6) /* Number of values in the enum. */
+
+/*
+ * Structure passed to describe procedure-like "procedures" that are not
+ * procedures (e.g. a lambda) so that their details can be reported correctly
+ * by [info frame]. Contains a sub-structure for each extra field.
+ */
+
+typedef Tcl_Obj * (GetFrameInfoValueProc)(ClientData clientData);
+typedef struct {
+ const char *name; /* Name of this field. */
+ GetFrameInfoValueProc *proc; /* Function to generate a Tcl_Obj* from the
+ * clientData, or just use the clientData
+ * directly (after casting) if NULL. */
+ ClientData clientData; /* Context for above function, or Tcl_Obj* if
+ * proc field is NULL. */
+} ExtraFrameInfoField;
+typedef struct {
+ int length; /* Length of array. */
+ ExtraFrameInfoField fields[2];
+ /* Really as long as necessary, but this is
+ * long enough for nearly anything. */
+} ExtraFrameInfo;
+
+/*
+ *----------------------------------------------------------------
+ * Data structures and procedures related to TclHandles, which are a very
+ * lightweight method of preserving enough information to determine if an
+ * arbitrary malloc'd block has been deleted.
+ *----------------------------------------------------------------
+ */
+
+typedef void **TclHandle;
+
+/*
+ *----------------------------------------------------------------
+ * Experimental flag value passed to Tcl_GetRegExpFromObj. Intended for use
+ * only by Expect. It will probably go away in a later release.
+ *----------------------------------------------------------------
+ */
+
+#define TCL_REG_BOSONLY 002000 /* Prepend \A to pattern so it only matches at
+ * the beginning of the string. */
+
+/*
+ * These are a thin layer over TclpThreadKeyDataGet and TclpThreadKeyDataSet
+ * when threads are used, or an emulation if there are no threads. These are
+ * really internal and Tcl clients should use Tcl_GetThreadData.
+ */
+
+MODULE_SCOPE void * TclThreadDataKeyGet(Tcl_ThreadDataKey *keyPtr);
+MODULE_SCOPE void TclThreadDataKeySet(Tcl_ThreadDataKey *keyPtr,
+ void *data);
+
+/*
+ * This is a convenience macro used to initialize a thread local storage ptr.
+ */
+
+#define TCL_TSD_INIT(keyPtr) \
+ (ThreadSpecificData *)Tcl_GetThreadData((keyPtr), sizeof(ThreadSpecificData))
+
+/*
+ *----------------------------------------------------------------
+ * Data structures related to bytecode compilation and execution. These are
+ * used primarily in tclCompile.c, tclExecute.c, and tclBasic.c.
+ *----------------------------------------------------------------
+ */
+
+/*
+ * Forward declaration to prevent errors when the forward references to
+ * Tcl_Parse and CompileEnv are encountered in the procedure type CompileProc
+ * declared below.
+ */
+
+struct CompileEnv;
+
+/*
+ * The type of procedures called by the Tcl bytecode compiler to compile
+ * commands. Pointers to these procedures are kept in the Command structure
+ * describing each command. The integer value returned by a CompileProc must
+ * be one of the following:
+ *
+ * TCL_OK Compilation completed normally.
+ * TCL_ERROR Compilation could not be completed. This can be just a
+ * judgment by the CompileProc that the command is too
+ * complex to compile effectively, or it can indicate
+ * that in the current state of the interp, the command
+ * would raise an error. The bytecode compiler will not
+ * do any error reporting at compiler time. Error
+ * reporting is deferred until the actual runtime,
+ * because by then changes in the interp state may allow
+ * the command to be successfully evaluated.
+ * TCL_OUT_LINE_COMPILE A source-compatible alias for TCL_ERROR, kept for the
+ * sake of old code only.
+ */
+
+#define TCL_OUT_LINE_COMPILE TCL_ERROR
+
+typedef int (CompileProc)(Tcl_Interp *interp, Tcl_Parse *parsePtr,
+ struct Command *cmdPtr, struct CompileEnv *compEnvPtr);
+
+/*
+ * The type of procedure called from the compilation hook point in
+ * SetByteCodeFromAny.
+ */
+
+typedef int (CompileHookProc)(Tcl_Interp *interp,
+ struct CompileEnv *compEnvPtr, ClientData clientData);
+
+/*
+ * The data structure for a (linked list of) execution stacks.
+ */
+
+typedef struct ExecStack {
+ struct ExecStack *prevPtr;
+ struct ExecStack *nextPtr;
+ Tcl_Obj **markerPtr;
+ Tcl_Obj **endPtr;
+ Tcl_Obj **tosPtr;
+ Tcl_Obj *stackWords[1];
+} ExecStack;
+
+/*
+ * The data structure defining the execution environment for ByteCode's.
+ * There is one ExecEnv structure per Tcl interpreter. It holds the evaluation
+ * stack that holds command operands and results. The stack grows towards
+ * increasing addresses. The member stackPtr points to the stackItems of the
+ * currently active execution stack.
+ */
+
+typedef struct CorContext {
+ struct CallFrame *framePtr;
+ struct CallFrame *varFramePtr;
+ struct CmdFrame *cmdFramePtr; /* See Interp.cmdFramePtr */
+ Tcl_HashTable *lineLABCPtr; /* See Interp.lineLABCPtr */
+} CorContext;
+
+typedef struct CoroutineData {
+ struct Command *cmdPtr; /* The command handle for the coroutine. */
+ struct ExecEnv *eePtr; /* The special execution environment (stacks,
+ * etc.) for the coroutine. */
+ struct ExecEnv *callerEEPtr;/* The execution environment for the caller of
+ * the coroutine, which might be the
+ * interpreter global environment or another
+ * coroutine. */
+ CorContext caller;
+ CorContext running;
+ Tcl_HashTable *lineLABCPtr; /* See Interp.lineLABCPtr */
+ void *stackLevel;
+ int auxNumLevels; /* While the coroutine is running the
+ * numLevels of the create/resume command is
+ * stored here; for suspended coroutines it
+ * holds the nesting numLevels at yield. */
+ int nargs; /* Number of args required for resuming this
+ * coroutine; -2 means "0 or 1" (default), -1
+ * means "any" */
+} CoroutineData;
+
+typedef struct ExecEnv {
+ ExecStack *execStackPtr; /* Points to the first item in the evaluation
+ * stack on the heap. */
+ Tcl_Obj *constants[2]; /* Pointers to constant "0" and "1" objs. */
+ struct Tcl_Interp *interp;
+ struct NRE_callback *callbackPtr;
+ /* Top callback in NRE's stack. */
+ struct CoroutineData *corPtr;
+ int rewind;
+} ExecEnv;
+
+#define COR_IS_SUSPENDED(corPtr) \
+ ((corPtr)->stackLevel == NULL)
+
+/*
+ * The definitions for the LiteralTable and LiteralEntry structures. Each
+ * interpreter contains a LiteralTable. It is used to reduce the storage
+ * needed for all the Tcl objects that hold the literals of scripts compiled
+ * by the interpreter. A literal's object is shared by all the ByteCodes that
+ * refer to the literal. Each distinct literal has one LiteralEntry entry in
+ * the LiteralTable. A literal table is a specialized hash table that is
+ * indexed by the literal's string representation, which may contain null
+ * characters.
+ *
+ * Note that we reduce the space needed for literals by sharing literal
+ * objects both within a ByteCode (each ByteCode contains a local
+ * LiteralTable) and across all an interpreter's ByteCodes (with the
+ * interpreter's global LiteralTable).
+ */
+
+typedef struct LiteralEntry {
+ struct LiteralEntry *nextPtr;
+ /* Points to next entry in this hash bucket or
+ * NULL if end of chain. */
+ Tcl_Obj *objPtr; /* Points to Tcl object that holds the
+ * literal's bytes and length. */
+ int refCount; /* If in an interpreter's global literal
+ * table, the number of ByteCode structures
+ * that share the literal object; the literal
+ * entry can be freed when refCount drops to
+ * 0. If in a local literal table, -1. */
+ Namespace *nsPtr; /* Namespace in which this literal is used. We
+ * try to avoid sharing literal non-FQ command
+ * names among different namespaces to reduce
+ * shimmering. */
+} LiteralEntry;
+
+typedef struct LiteralTable {
+ LiteralEntry **buckets; /* Pointer to bucket array. Each element
+ * points to first entry in bucket's hash
+ * chain, or NULL. */
+ LiteralEntry *staticBuckets[TCL_SMALL_HASH_TABLE];
+ /* Bucket array used for small tables to avoid
+ * mallocs and frees. */
+ int numBuckets; /* Total number of buckets allocated at
+ * **buckets. */
+ int numEntries; /* Total number of entries present in
+ * table. */
+ int rebuildSize; /* Enlarge table when numEntries gets to be
+ * this large. */
+ int mask; /* Mask value used in hashing function. */
+} LiteralTable;
+
+/*
+ * The following structure defines for each Tcl interpreter various
+ * statistics-related information about the bytecode compiler and
+ * interpreter's operation in that interpreter.
+ */
+
+#ifdef TCL_COMPILE_STATS
+typedef struct ByteCodeStats {
+ long numExecutions; /* Number of ByteCodes executed. */
+ long numCompilations; /* Number of ByteCodes created. */
+ long numByteCodesFreed; /* Number of ByteCodes destroyed. */
+ long instructionCount[256]; /* Number of times each instruction was
+ * executed. */
+
+ double totalSrcBytes; /* Total source bytes ever compiled. */
+ double totalByteCodeBytes; /* Total bytes for all ByteCodes. */
+ double currentSrcBytes; /* Src bytes for all current ByteCodes. */
+ double currentByteCodeBytes;/* Code bytes in all current ByteCodes. */
+
+ long srcCount[32]; /* Source size distribution: # of srcs of
+ * size [2**(n-1)..2**n), n in [0..32). */
+ long byteCodeCount[32]; /* ByteCode size distribution. */
+ long lifetimeCount[32]; /* ByteCode lifetime distribution (ms). */
+
+ double currentInstBytes; /* Instruction bytes-current ByteCodes. */
+ double currentLitBytes; /* Current literal bytes. */
+ double currentExceptBytes; /* Current exception table bytes. */
+ double currentAuxBytes; /* Current auxiliary information bytes. */
+ double currentCmdMapBytes; /* Current src<->code map bytes. */
+
+ long numLiteralsCreated; /* Total literal objects ever compiled. */
+ double totalLitStringBytes; /* Total string bytes in all literals. */
+ double currentLitStringBytes;
+ /* String bytes in current literals. */
+ long literalCount[32]; /* Distribution of literal string sizes. */
+} ByteCodeStats;
+#endif /* TCL_COMPILE_STATS */
+
+/*
+ * Structure used in implementation of those core ensembles which are
+ * partially compiled. Used as an array of these, with a terminating field
+ * whose 'name' is NULL.
+ */
+
+typedef struct {
+ const char *name; /* The name of the subcommand. */
+ Tcl_ObjCmdProc *proc; /* The implementation of the subcommand. */
+ CompileProc *compileProc; /* The compiler for the subcommand. */
+ Tcl_ObjCmdProc *nreProc; /* NRE implementation of this command. */
+ ClientData clientData; /* Any clientData to give the command. */
+ int unsafe; /* Whether this command is to be hidden by
+ * default in a safe interpreter. */
+} EnsembleImplMap;
+
+/*
+ *----------------------------------------------------------------
+ * Data structures related to commands.
+ *----------------------------------------------------------------
+ */
+
+/*
+ * An imported command is created in an namespace when it imports a "real"
+ * command from another namespace. An imported command has a Command structure
+ * that points (via its ClientData value) to the "real" Command structure in
+ * the source namespace's command table. The real command records all the
+ * imported commands that refer to it in a list of ImportRef structures so
+ * that they can be deleted when the real command is deleted.
+ */
+
+typedef struct ImportRef {
+ struct Command *importedCmdPtr;
+ /* Points to the imported command created in
+ * an importing namespace; this command
+ * redirects its invocations to the "real"
+ * command. */
+ struct ImportRef *nextPtr; /* Next element on the linked list of imported
+ * commands that refer to the "real" command.
+ * The real command deletes these imported
+ * commands on this list when it is
+ * deleted. */
+} ImportRef;
+
+/*
+ * Data structure used as the ClientData of imported commands: commands
+ * created in an namespace when it imports a "real" command from another
+ * namespace.
+ */
+
+typedef struct ImportedCmdData {
+ struct Command *realCmdPtr; /* "Real" command that this imported command
+ * refers to. */
+ struct Command *selfPtr; /* Pointer to this imported command. Needed
+ * only when deleting it in order to remove it
+ * from the real command's linked list of
+ * imported commands that refer to it. */
+} ImportedCmdData;
+
+/*
+ * A Command structure exists for each command in a namespace. The Tcl_Command
+ * opaque type actually refers to these structures.
+ */
+
+typedef struct Command {
+ Tcl_HashEntry *hPtr; /* Pointer to the hash table entry that refers
+ * to this command. The hash table is either a
+ * namespace's command table or an
+ * interpreter's hidden command table. This
+ * pointer is used to get a command's name
+ * from its Tcl_Command handle. NULL means
+ * that the hash table entry has been removed
+ * already (this can happen if deleteProc
+ * causes the command to be deleted or
+ * recreated). */
+ Namespace *nsPtr; /* Points to the namespace containing this
+ * command. */
+ int refCount; /* 1 if in command hashtable plus 1 for each
+ * reference from a CmdName Tcl object
+ * representing a command's name in a ByteCode
+ * instruction sequence. This structure can be
+ * freed when refCount becomes zero. */
+ int cmdEpoch; /* Incremented to invalidate any references
+ * that point to this command when it is
+ * renamed, deleted, hidden, or exposed. */
+ CompileProc *compileProc; /* Procedure called to compile command. NULL
+ * if no compile proc exists for command. */
+ Tcl_ObjCmdProc *objProc; /* Object-based command procedure. */
+ ClientData objClientData; /* Arbitrary value passed to object proc. */
+ Tcl_CmdProc *proc; /* String-based command procedure. */
+ ClientData clientData; /* Arbitrary value passed to string proc. */
+ Tcl_CmdDeleteProc *deleteProc;
+ /* Procedure invoked when deleting command to,
+ * e.g., free all client data. */
+ ClientData deleteData; /* Arbitrary value passed to deleteProc. */
+ int flags; /* Miscellaneous bits of information about
+ * command. See below for definitions. */
+ ImportRef *importRefPtr; /* List of each imported Command created in
+ * another namespace when this command is
+ * imported. These imported commands redirect
+ * invocations back to this command. The list
+ * is used to remove all those imported
+ * commands when deleting this "real"
+ * command. */
+ CommandTrace *tracePtr; /* First in list of all traces set for this
+ * command. */
+ Tcl_ObjCmdProc *nreProc; /* NRE implementation of this command. */
+} Command;
+
+/*
+ * Flag bits for commands.
+ *
+ * CMD_IS_DELETED - Means that the command is in the process of
+ * being deleted (its deleteProc is currently
+ * executing). Other attempts to delete the
+ * command should be ignored.
+ * CMD_TRACE_ACTIVE - 1 means that trace processing is currently
+ * underway for a rename/delete change. See the
+ * two flags below for which is currently being
+ * processed.
+ * CMD_HAS_EXEC_TRACES - 1 means that this command has at least one
+ * execution trace (as opposed to simple
+ * delete/rename traces) in its tracePtr list.
+ * CMD_COMPILES_EXPANDED - 1 means that this command has a compiler that
+ * can handle expansion (provided it is not the
+ * first word).
+ * TCL_TRACE_RENAME - A rename trace is in progress. Further
+ * recursive renames will not be traced.
+ * TCL_TRACE_DELETE - A delete trace is in progress. Further
+ * recursive deletes will not be traced.
+ * (these last two flags are defined in tcl.h)
+ */
+
+#define CMD_IS_DELETED 0x01
+#define CMD_TRACE_ACTIVE 0x02
+#define CMD_HAS_EXEC_TRACES 0x04
+#define CMD_COMPILES_EXPANDED 0x08
+#define CMD_REDEF_IN_PROGRESS 0x10
+#define CMD_VIA_RESOLVER 0x20
+
+
+/*
+ *----------------------------------------------------------------
+ * Data structures related to name resolution procedures.
+ *----------------------------------------------------------------
+ */
+
+/*
+ * The interpreter keeps a linked list of name resolution schemes. The scheme
+ * for a namespace is consulted first, followed by the list of schemes in an
+ * interpreter, followed by the default name resolution in Tcl. Schemes are
+ * added/removed from the interpreter's list by calling Tcl_AddInterpResolver
+ * and Tcl_RemoveInterpResolver.
+ */
+
+typedef struct ResolverScheme {
+ char *name; /* Name identifying this scheme. */
+ Tcl_ResolveCmdProc *cmdResProc;
+ /* Procedure handling command name
+ * resolution. */
+ Tcl_ResolveVarProc *varResProc;
+ /* Procedure handling variable name resolution
+ * for variables that can only be handled at
+ * runtime. */
+ Tcl_ResolveCompiledVarProc *compiledVarResProc;
+ /* Procedure handling variable name resolution
+ * at compile time. */
+
+ struct ResolverScheme *nextPtr;
+ /* Pointer to next record in linked list. */
+} ResolverScheme;
+
+/*
+ * Forward declaration of the TIP#143 limit handler structure.
+ */
+
+typedef struct LimitHandler LimitHandler;
+
+/*
+ * TIP #268.
+ * Values for the selection mode, i.e the package require preferences.
+ */
+
+enum PkgPreferOptions {
+ PKG_PREFER_LATEST, PKG_PREFER_STABLE
+};
+
+/*
+ *----------------------------------------------------------------
+ * This structure shadows the first few fields of the memory cache for the
+ * allocator defined in tclThreadAlloc.c; it has to be kept in sync with the
+ * definition there.
+ * Some macros require knowledge of some fields in the struct in order to
+ * avoid hitting the TSD unnecessarily. In order to facilitate this, a pointer
+ * to the relevant fields is kept in the allocCache field in struct Interp.
+ *----------------------------------------------------------------
+ */
+
+typedef struct AllocCache {
+ struct Cache *nextPtr; /* Linked list of cache entries. */
+ Tcl_ThreadId owner; /* Which thread's cache is this? */
+ Tcl_Obj *firstObjPtr; /* List of free objects for thread. */
+ int numObjects; /* Number of objects for thread. */
+} AllocCache;
+
+/*
+ *----------------------------------------------------------------
+ * This structure defines an interpreter, which is a collection of commands
+ * plus other state information related to interpreting commands, such as
+ * variable storage. Primary responsibility for this data structure is in
+ * tclBasic.c, but almost every Tcl source file uses something in here.
+ *----------------------------------------------------------------
+ */
+
+typedef struct Interp {
+ /*
+ * Note: the first three fields must match exactly the fields in a
+ * Tcl_Interp struct (see tcl.h). If you change one, be sure to change the
+ * other.
+ *
+ * The interpreter's result is held in both the string and the
+ * objResultPtr fields. These fields hold, respectively, the result's
+ * string or object value. The interpreter's result is always in the
+ * result field if that is non-empty, otherwise it is in objResultPtr.
+ * The two fields are kept consistent unless some C code sets
+ * interp->result directly. Programs should not access result and
+ * objResultPtr directly; instead, they should always get and set the
+ * result using procedures such as Tcl_SetObjResult, Tcl_GetObjResult, and
+ * Tcl_GetStringResult. See the SetResult man page for details.
+ */
+
+ char *result; /* If the last command returned a string
+ * result, this points to it. Should not be
+ * accessed directly; see comment above. */
+ Tcl_FreeProc *freeProc; /* Zero means a string result is statically
+ * allocated. TCL_DYNAMIC means string result
+ * was allocated with ckalloc and should be
+ * freed with ckfree. Other values give
+ * address of procedure to invoke to free the
+ * string result. Tcl_Eval must free it before
+ * executing next command. */
+ int errorLine; /* When TCL_ERROR is returned, this gives the
+ * line number in the command where the error
+ * occurred (1 means first line). */
+ const struct TclStubs *stubTable;
+ /* Pointer to the exported Tcl stub table. On
+ * previous versions of Tcl this is a pointer
+ * to the objResultPtr or a pointer to a
+ * buckets array in a hash table. We therefore
+ * have to do some careful checking before we
+ * can use this. */
+
+ TclHandle handle; /* Handle used to keep track of when this
+ * interp is deleted. */
+
+ Namespace *globalNsPtr; /* The interpreter's global namespace. */
+ Tcl_HashTable *hiddenCmdTablePtr;
+ /* Hash table used by tclBasic.c to keep track
+ * of hidden commands on a per-interp
+ * basis. */
+ ClientData interpInfo; /* Information used by tclInterp.c to keep
+ * track of master/slave interps on a
+ * per-interp basis. */
+ union {
+ void (*optimizer)(void *envPtr);
+ Tcl_HashTable unused2; /* No longer used (was mathFuncTable). The
+ * unused space in interp was repurposed for
+ * pluggable bytecode optimizers. The core
+ * contains one optimizer, which can be
+ * selectively overridden by extensions. */
+ } extra;
+
+ /*
+ * Information related to procedures and variables. See tclProc.c and
+ * tclVar.c for usage.
+ */
+
+ int numLevels; /* Keeps track of how many nested calls to
+ * Tcl_Eval are in progress for this
+ * interpreter. It's used to delay deletion of
+ * the table until all Tcl_Eval invocations
+ * are completed. */
+ int maxNestingDepth; /* If numLevels exceeds this value then Tcl
+ * assumes that infinite recursion has
+ * occurred and it generates an error. */
+ CallFrame *framePtr; /* Points to top-most in stack of all nested
+ * procedure invocations. */
+ CallFrame *varFramePtr; /* Points to the call frame whose variables
+ * are currently in use (same as framePtr
+ * unless an "uplevel" command is
+ * executing). */
+ ActiveVarTrace *activeVarTracePtr;
+ /* First in list of active traces for interp,
+ * or NULL if no active traces. */
+ int returnCode; /* [return -code] parameter. */
+ CallFrame *rootFramePtr; /* Global frame pointer for this
+ * interpreter. */
+ Namespace *lookupNsPtr; /* Namespace to use ONLY on the next
+ * TCL_EVAL_INVOKE call to Tcl_EvalObjv. */
+
+ /*
+ * Information used by Tcl_AppendResult to keep track of partial results.
+ * See Tcl_AppendResult code for details.
+ */
+
+ char *appendResult; /* Storage space for results generated by
+ * Tcl_AppendResult. Ckalloc-ed. NULL means
+ * not yet allocated. */
+ int appendAvl; /* Total amount of space available at
+ * partialResult. */
+ int appendUsed; /* Number of non-null bytes currently stored
+ * at partialResult. */
+
+ /*
+ * Information about packages. Used only in tclPkg.c.
+ */
+
+ Tcl_HashTable packageTable; /* Describes all of the packages loaded in or
+ * available to this interpreter. Keys are
+ * package names, values are (Package *)
+ * pointers. */
+ char *packageUnknown; /* Command to invoke during "package require"
+ * commands for packages that aren't described
+ * in packageTable. Ckalloc'ed, may be
+ * NULL. */
+ /*
+ * Miscellaneous information:
+ */
+
+ int cmdCount; /* Total number of times a command procedure
+ * has been called for this interpreter. */
+ int evalFlags; /* Flags to control next call to Tcl_Eval.
+ * Normally zero, but may be set before
+ * calling Tcl_Eval. See below for valid
+ * values. */
+ int unused1; /* No longer used (was termOffset) */
+ LiteralTable literalTable; /* Contains LiteralEntry's describing all Tcl
+ * objects holding literals of scripts
+ * compiled by the interpreter. Indexed by the
+ * string representations of literals. Used to
+ * avoid creating duplicate objects. */
+ int compileEpoch; /* Holds the current "compilation epoch" for
+ * this interpreter. This is incremented to
+ * invalidate existing ByteCodes when, e.g., a
+ * command with a compile procedure is
+ * redefined. */
+ Proc *compiledProcPtr; /* If a procedure is being compiled, a pointer
+ * to its Proc structure; otherwise, this is
+ * NULL. Set by ObjInterpProc in tclProc.c and
+ * used by tclCompile.c to process local
+ * variables appropriately. */
+ ResolverScheme *resolverPtr;
+ /* Linked list of name resolution schemes
+ * added to this interpreter. Schemes are
+ * added and removed by calling
+ * Tcl_AddInterpResolvers and
+ * Tcl_RemoveInterpResolver respectively. */
+ Tcl_Obj *scriptFile; /* NULL means there is no nested source
+ * command active; otherwise this points to
+ * pathPtr of the file being sourced. */
+ int flags; /* Various flag bits. See below. */
+ long randSeed; /* Seed used for rand() function. */
+ Trace *tracePtr; /* List of traces for this interpreter. */
+ Tcl_HashTable *assocData; /* Hash table for associating data with this
+ * interpreter. Cleaned up when this
+ * interpreter is deleted. */
+ struct ExecEnv *execEnvPtr; /* Execution environment for Tcl bytecode
+ * execution. Contains a pointer to the Tcl
+ * evaluation stack. */
+ Tcl_Obj *emptyObjPtr; /* Points to an object holding an empty
+ * string. Returned by Tcl_ObjSetVar2 when
+ * variable traces change a variable in a
+ * gross way. */
+ char resultSpace[TCL_RESULT_SIZE+1];
+ /* Static space holding small results. */
+ Tcl_Obj *objResultPtr; /* If the last command returned an object
+ * result, this points to it. Should not be
+ * accessed directly; see comment above. */
+ Tcl_ThreadId threadId; /* ID of thread that owns the interpreter. */
+
+ ActiveCommandTrace *activeCmdTracePtr;
+ /* First in list of active command traces for
+ * interp, or NULL if no active traces. */
+ ActiveInterpTrace *activeInterpTracePtr;
+ /* First in list of active traces for interp,
+ * or NULL if no active traces. */
+
+ int tracesForbiddingInline; /* Count of traces (in the list headed by
+ * tracePtr) that forbid inline bytecode
+ * compilation. */
+
+ /*
+ * Fields used to manage extensible return options (TIP 90).
+ */
+
+ Tcl_Obj *returnOpts; /* A dictionary holding the options to the
+ * last [return] command. */
+
+ Tcl_Obj *errorInfo; /* errorInfo value (now as a Tcl_Obj). */
+ Tcl_Obj *eiVar; /* cached ref to ::errorInfo variable. */
+ Tcl_Obj *errorCode; /* errorCode value (now as a Tcl_Obj). */
+ Tcl_Obj *ecVar; /* cached ref to ::errorInfo variable. */
+ int returnLevel; /* [return -level] parameter. */
+
+ /*
+ * Resource limiting framework support (TIP#143).
+ */
+
+ struct {
+ int active; /* Flag values defining which limits have been
+ * set. */
+ int granularityTicker; /* Counter used to determine how often to
+ * check the limits. */
+ int exceeded; /* Which limits have been exceeded, described
+ * as flag values the same as the 'active'
+ * field. */
+
+ int cmdCount; /* Limit for how many commands to execute in
+ * the interpreter. */
+ LimitHandler *cmdHandlers;
+ /* Handlers to execute when the limit is
+ * reached. */
+ int cmdGranularity; /* Mod factor used to determine how often to
+ * evaluate the limit check. */
+
+ Tcl_Time time; /* Time limit for execution within the
+ * interpreter. */
+ LimitHandler *timeHandlers;
+ /* Handlers to execute when the limit is
+ * reached. */
+ int timeGranularity; /* Mod factor used to determine how often to
+ * evaluate the limit check. */
+ Tcl_TimerToken timeEvent;
+ /* Handle for a timer callback that will occur
+ * when the time-limit is exceeded. */
+
+ Tcl_HashTable callbacks;/* Mapping from (interp,type) pair to data
+ * used to install a limit handler callback to
+ * run in _this_ interp when the limit is
+ * exceeded. */
+ } limit;
+
+ /*
+ * Information for improved default error generation from ensembles
+ * (TIP#112).
+ */
+
+ struct {
+ Tcl_Obj *const *sourceObjs;
+ /* What arguments were actually input into the
+ * *root* ensemble command? (Nested ensembles
+ * don't rewrite this.) NULL if we're not
+ * processing an ensemble. */
+ int numRemovedObjs; /* How many arguments have been stripped off
+ * because of ensemble processing. */
+ int numInsertedObjs; /* How many of the current arguments were
+ * inserted by an ensemble. */
+ } ensembleRewrite;
+
+ /*
+ * TIP #219: Global info for the I/O system.
+ */
+
+ Tcl_Obj *chanMsg; /* Error message set by channel drivers, for
+ * the propagation of arbitrary Tcl errors.
+ * This information, if present (chanMsg not
+ * NULL), takes precedence over a POSIX error
+ * code returned by a channel operation. */
+
+ /*
+ * Source code origin information (TIP #280).
+ */
+
+ CmdFrame *cmdFramePtr; /* Points to the command frame containing the
+ * location information for the current
+ * command. */
+ const CmdFrame *invokeCmdFramePtr;
+ /* Points to the command frame which is the
+ * invoking context of the bytecode compiler.
+ * NULL when the byte code compiler is not
+ * active. */
+ int invokeWord; /* Index of the word in the command which
+ * is getting compiled. */
+ Tcl_HashTable *linePBodyPtr;/* This table remembers for each statically
+ * defined procedure the location information
+ * for its body. It is keyed by the address of
+ * the Proc structure for a procedure. The
+ * values are "struct CmdFrame*". */
+ Tcl_HashTable *lineBCPtr; /* This table remembers for each ByteCode
+ * object the location information for its
+ * body. It is keyed by the address of the
+ * Proc structure for a procedure. The values
+ * are "struct ExtCmdLoc*". (See
+ * tclCompile.h) */
+ Tcl_HashTable *lineLABCPtr;
+ Tcl_HashTable *lineLAPtr; /* This table remembers for each argument of a
+ * command on the execution stack the index of
+ * the argument in the command, and the
+ * location data of the command. It is keyed
+ * by the address of the Tcl_Obj containing
+ * the argument. The values are "struct
+ * CFWord*" (See tclBasic.c). This allows
+ * commands like uplevel, eval, etc. to find
+ * location information for their arguments,
+ * if they are a proper literal argument to an
+ * invoking command. Alt view: An index to the
+ * CmdFrame stack keyed by command argument
+ * holders. */
+ ContLineLoc *scriptCLLocPtr;/* This table points to the location data for
+ * invisible continuation lines in the script,
+ * if any. This pointer is set by the function
+ * TclEvalObjEx() in file "tclBasic.c", and
+ * used by function ...() in the same file.
+ * It does for the eval/direct path of script
+ * execution what CompileEnv.clLoc does for
+ * the bytecode compiler.
+ */
+ /*
+ * TIP #268. The currently active selection mode, i.e. the package require
+ * preferences.
+ */
+
+ int packagePrefer; /* Current package selection mode. */
+
+ /*
+ * Hashtables for variable traces and searches.
+ */
+
+ Tcl_HashTable varTraces; /* Hashtable holding the start of a variable's
+ * active trace list; varPtr is the key. */
+ Tcl_HashTable varSearches; /* Hashtable holding the start of a variable's
+ * active searches list; varPtr is the key. */
+ /*
+ * The thread-specific data ekeko: cache pointers or values that
+ * (a) do not change during the thread's lifetime
+ * (b) require access to TSD to determine at runtime
+ * (c) are accessed very often (e.g., at each command call)
+ *
+ * Note that these are the same for all interps in the same thread. They
+ * just have to be initialised for the thread's master interp, slaves
+ * inherit the value.
+ *
+ * They are used by the macros defined below.
+ */
+
+ AllocCache *allocCache;
+ void *pendingObjDataPtr; /* Pointer to the Cache and PendingObjData
+ * structs for this interp's thread; see
+ * tclObj.c and tclThreadAlloc.c */
+ int *asyncReadyPtr; /* Pointer to the asyncReady indicator for
+ * this interp's thread; see tclAsync.c */
+ /*
+ * The pointer to the object system root ekeko. c.f. TIP #257.
+ */
+ void *objectFoundation; /* Pointer to the Foundation structure of the
+ * object system, which contains things like
+ * references to key namespaces. See
+ * tclOOInt.h and tclOO.c for real definition
+ * and setup. */
+
+ struct NRE_callback *deferredCallbacks;
+ /* Callbacks that are set previous to a call
+ * to some Eval function but that actually
+ * belong to the command that is about to be
+ * called - i.e., they should be run *before*
+ * any tailcall is invoked. */
+
+ /*
+ * TIP #285, Script cancellation support.
+ */
+
+ Tcl_AsyncHandler asyncCancel;
+ /* Async handler token for Tcl_CancelEval. */
+ Tcl_Obj *asyncCancelMsg; /* Error message set by async cancel handler
+ * for the propagation of arbitrary Tcl
+ * errors. This information, if present
+ * (asyncCancelMsg not NULL), takes precedence
+ * over the default error messages returned by
+ * a script cancellation operation. */
+
+ /*
+ * TIP #348 IMPLEMENTATION - Substituted error stack
+ */
+ Tcl_Obj *errorStack; /* [info errorstack] value (as a Tcl_Obj). */
+ Tcl_Obj *upLiteral; /* "UP" literal for [info errorstack] */
+ Tcl_Obj *callLiteral; /* "CALL" literal for [info errorstack] */
+ Tcl_Obj *innerLiteral; /* "INNER" literal for [info errorstack] */
+ Tcl_Obj *innerContext; /* cached list for fast reallocation */
+ int resetErrorStack; /* controls cleaning up of ::errorStack */
+
+#ifdef TCL_COMPILE_STATS
+ /*
+ * Statistical information about the bytecode compiler and interpreter's
+ * operation. This should be the last field of Interp.
+ */
+
+ ByteCodeStats stats; /* Holds compilation and execution statistics
+ * for this interpreter. */
+#endif /* TCL_COMPILE_STATS */
+} Interp;
+
+/*
+ * Macros that use the TSD-ekeko.
+ */
+
+#define TclAsyncReady(iPtr) \
+ *((iPtr)->asyncReadyPtr)
+
+/*
+ * Macros for script cancellation support (TIP #285).
+ */
+
+#define TclCanceled(iPtr) \
+ (((iPtr)->flags & CANCELED) || ((iPtr)->flags & TCL_CANCEL_UNWIND))
+
+#define TclSetCancelFlags(iPtr, cancelFlags) \
+ (iPtr)->flags |= CANCELED; \
+ if ((cancelFlags) & TCL_CANCEL_UNWIND) { \
+ (iPtr)->flags |= TCL_CANCEL_UNWIND; \
+ }
+
+#define TclUnsetCancelFlags(iPtr) \
+ (iPtr)->flags &= (~(CANCELED | TCL_CANCEL_UNWIND))
+
+/*
+ * Macros for splicing into and out of doubly linked lists. They assume
+ * existence of struct items 'prevPtr' and 'nextPtr'.
+ *
+ * a = element to add or remove.
+ * b = list head.
+ *
+ * TclSpliceIn adds to the head of the list.
+ */
+
+#define TclSpliceIn(a,b) \
+ (a)->nextPtr = (b); \
+ if ((b) != NULL) { \
+ (b)->prevPtr = (a); \
+ } \
+ (a)->prevPtr = NULL, (b) = (a);
+
+#define TclSpliceOut(a,b) \
+ if ((a)->prevPtr != NULL) { \
+ (a)->prevPtr->nextPtr = (a)->nextPtr; \
+ } else { \
+ (b) = (a)->nextPtr; \
+ } \
+ if ((a)->nextPtr != NULL) { \
+ (a)->nextPtr->prevPtr = (a)->prevPtr; \
+ }
+
+/*
+ * EvalFlag bits for Interp structures:
+ *
+ * TCL_ALLOW_EXCEPTIONS 1 means it's OK for the script to terminate with a
+ * code other than TCL_OK or TCL_ERROR; 0 means codes
+ * other than these should be turned into errors.
+ */
+
+#define TCL_ALLOW_EXCEPTIONS 0x04
+#define TCL_EVAL_FILE 0x02
+#define TCL_EVAL_SOURCE_IN_FRAME 0x10
+#define TCL_EVAL_NORESOLVE 0x20
+
+/*
+ * Flag bits for Interp structures:
+ *
+ * DELETED: Non-zero means the interpreter has been deleted:
+ * don't process any more commands for it, and destroy
+ * the structure as soon as all nested invocations of
+ * Tcl_Eval are done.
+ * ERR_ALREADY_LOGGED: Non-zero means information has already been logged in
+ * iPtr->errorInfo for the current Tcl_Eval instance, so
+ * Tcl_Eval needn't log it (used to implement the "error
+ * message log" command).
+ * DONT_COMPILE_CMDS_INLINE: Non-zero means that the bytecode compiler should
+ * not compile any commands into an inline sequence of
+ * instructions. This is set 1, for example, when command
+ * traces are requested.
+ * RAND_SEED_INITIALIZED: Non-zero means that the randSeed value of the interp
+ * has not be initialized. This is set 1 when we first
+ * use the rand() or srand() functions.
+ * SAFE_INTERP: Non zero means that the current interp is a safe
+ * interp (i.e. it has only the safe commands installed,
+ * less privilege than a regular interp).
+ * INTERP_DEBUG_FRAME: Used for switching on various extra interpreter
+ * debug/info mechanisms (e.g. info frame eval/uplevel
+ * tracing) which are performance intensive.
+ * INTERP_TRACE_IN_PROGRESS: Non-zero means that an interp trace is currently
+ * active; so no further trace callbacks should be
+ * invoked.
+ * INTERP_ALTERNATE_WRONG_ARGS: Used for listing second and subsequent forms
+ * of the wrong-num-args string in Tcl_WrongNumArgs.
+ * Makes it append instead of replacing and uses
+ * different intermediate text.
+ * CANCELED: Non-zero means that the script in progress should be
+ * canceled as soon as possible. This can be checked by
+ * extensions (and the core itself) by calling
+ * Tcl_Canceled and checking if TCL_ERROR is returned.
+ * This is a one-shot flag that is reset immediately upon
+ * being detected; however, if the TCL_CANCEL_UNWIND flag
+ * is set Tcl_Canceled will continue to report that the
+ * script in progress has been canceled thereby allowing
+ * the evaluation stack for the interp to be fully
+ * unwound.
+ *
+ * WARNING: For the sake of some extensions that have made use of former
+ * internal values, do not re-use the flag values 2 (formerly ERR_IN_PROGRESS)
+ * or 8 (formerly ERROR_CODE_SET).
+ */
+
+#define DELETED 1
+#define ERR_ALREADY_LOGGED 4
+#define INTERP_DEBUG_FRAME 0x10
+#define DONT_COMPILE_CMDS_INLINE 0x20
+#define RAND_SEED_INITIALIZED 0x40
+#define SAFE_INTERP 0x80
+#define INTERP_TRACE_IN_PROGRESS 0x200
+#define INTERP_ALTERNATE_WRONG_ARGS 0x400
+#define ERR_LEGACY_COPY 0x800
+#define CANCELED 0x1000
+
+/*
+ * Maximum number of levels of nesting permitted in Tcl commands (used to
+ * catch infinite recursion).
+ */
+
+#define MAX_NESTING_DEPTH 1000
+
+/*
+ * The macro below is used to modify a "char" value (e.g. by casting it to an
+ * unsigned character) so that it can be used safely with macros such as
+ * isspace.
+ */
+
+#define UCHAR(c) ((unsigned char) (c))
+
+/*
+ * This macro is used to properly align the memory allocated by Tcl, giving
+ * the same alignment as the native malloc.
+ */
+
+#if defined(__APPLE__)
+#define TCL_ALLOCALIGN 16
+#else
+#define TCL_ALLOCALIGN (2*sizeof(void *))
+#endif
+
+/*
+ * This macro is used to determine the offset needed to safely allocate any
+ * data structure in memory. Given a starting offset or size, it "rounds up"
+ * or "aligns" the offset to the next 8-byte boundary so that any data
+ * structure can be placed at the resulting offset without fear of an
+ * alignment error.
+ *
+ * WARNING!! DO NOT USE THIS MACRO TO ALIGN POINTERS: it will produce the
+ * wrong result on platforms that allocate addresses that are divisible by 4
+ * or 2. Only use it for offsets or sizes.
+ *
+ * This macro is only used by tclCompile.c in the core (Bug 926445). It
+ * however not be made file static, as extensions that touch bytecodes
+ * (notably tbcload) require it.
+ */
+
+#define TCL_ALIGN(x) (((int)(x) + 7) & ~7)
+
+/*
+ * The following enum values are used to specify the runtime platform setting
+ * of the tclPlatform variable.
+ */
+
+typedef enum {
+ TCL_PLATFORM_UNIX = 0, /* Any Unix-like OS. */
+ TCL_PLATFORM_WINDOWS = 2 /* Any Microsoft Windows OS. */
+} TclPlatformType;
+
+/*
+ * The following enum values are used to indicate the translation of a Tcl
+ * channel. Declared here so that each platform can define
+ * TCL_PLATFORM_TRANSLATION to the native translation on that platform.
+ */
+
+typedef enum TclEolTranslation {
+ TCL_TRANSLATE_AUTO, /* Eol == \r, \n and \r\n. */
+ TCL_TRANSLATE_CR, /* Eol == \r. */
+ TCL_TRANSLATE_LF, /* Eol == \n. */
+ TCL_TRANSLATE_CRLF /* Eol == \r\n. */
+} TclEolTranslation;
+
+/*
+ * Flags for TclInvoke:
+ *
+ * TCL_INVOKE_HIDDEN Invoke a hidden command; if not set, invokes
+ * an exposed command.
+ * TCL_INVOKE_NO_UNKNOWN If set, "unknown" is not invoked if the
+ * command to be invoked is not found. Only has
+ * an effect if invoking an exposed command,
+ * i.e. if TCL_INVOKE_HIDDEN is not also set.
+ * TCL_INVOKE_NO_TRACEBACK Does not record traceback information if the
+ * invoked command returns an error. Used if the
+ * caller plans on recording its own traceback
+ * information.
+ */
+
+#define TCL_INVOKE_HIDDEN (1<<0)
+#define TCL_INVOKE_NO_UNKNOWN (1<<1)
+#define TCL_INVOKE_NO_TRACEBACK (1<<2)
+
+/*
+ * The structure used as the internal representation of Tcl list objects. This
+ * struct is grown (reallocated and copied) as necessary to hold all the
+ * list's element pointers. The struct might contain more slots than currently
+ * used to hold all element pointers. This is done to make append operations
+ * faster.
+ */
+
+typedef struct List {
+ int refCount;
+ int maxElemCount; /* Total number of element array slots. */
+ int elemCount; /* Current number of list elements. */
+ int canonicalFlag; /* Set if the string representation was
+ * derived from the list representation. May
+ * be ignored if there is no string rep at
+ * all.*/
+ Tcl_Obj *elements; /* First list element; the struct is grown to
+ * accommodate all elements. */
+} List;
+
+#define LIST_MAX \
+ (1 + (int)(((size_t)UINT_MAX - sizeof(List))/sizeof(Tcl_Obj *)))
+#define LIST_SIZE(numElems) \
+ (unsigned)(sizeof(List) + (((numElems) - 1) * sizeof(Tcl_Obj *)))
+
+/*
+ * Macro used to get the elements of a list object.
+ */
+
+#define ListRepPtr(listPtr) \
+ ((List *) (listPtr)->internalRep.twoPtrValue.ptr1)
+
+#define ListSetIntRep(objPtr, listRepPtr) \
+ (objPtr)->internalRep.twoPtrValue.ptr1 = (void *)(listRepPtr), \
+ (objPtr)->internalRep.twoPtrValue.ptr2 = NULL, \
+ (listRepPtr)->refCount++, \
+ (objPtr)->typePtr = &tclListType
+
+#define ListObjGetElements(listPtr, objc, objv) \
+ ((objv) = &(ListRepPtr(listPtr)->elements), \
+ (objc) = ListRepPtr(listPtr)->elemCount)
+
+#define ListObjLength(listPtr, len) \
+ ((len) = ListRepPtr(listPtr)->elemCount)
+
+#define ListObjIsCanonical(listPtr) \
+ (((listPtr)->bytes == NULL) || ListRepPtr(listPtr)->canonicalFlag)
+
+#define TclListObjGetElements(interp, listPtr, objcPtr, objvPtr) \
+ (((listPtr)->typePtr == &tclListType) \
+ ? ((ListObjGetElements((listPtr), *(objcPtr), *(objvPtr))), TCL_OK)\
+ : Tcl_ListObjGetElements((interp), (listPtr), (objcPtr), (objvPtr)))
+
+#define TclListObjLength(interp, listPtr, lenPtr) \
+ (((listPtr)->typePtr == &tclListType) \
+ ? ((ListObjLength((listPtr), *(lenPtr))), TCL_OK)\
+ : Tcl_ListObjLength((interp), (listPtr), (lenPtr)))
+
+#define TclListObjIsCanonical(listPtr) \
+ (((listPtr)->typePtr == &tclListType) ? ListObjIsCanonical((listPtr)) : 0)
+
+/*
+ * Modes for collecting (or not) in the implementations of TclNRForeachCmd,
+ * TclNRLmapCmd and their compilations.
+ */
+
+#define TCL_EACH_KEEP_NONE 0 /* Discard iteration result like [foreach] */
+#define TCL_EACH_COLLECT 1 /* Collect iteration result like [lmap] */
+
+/*
+ * Macros providing a faster path to integers: Tcl_GetLongFromObj,
+ * Tcl_GetIntFromObj and TclGetIntForIndex.
+ *
+ * WARNING: these macros eval their args more than once.
+ */
+
+#define TclGetLongFromObj(interp, objPtr, longPtr) \
+ (((objPtr)->typePtr == &tclIntType) \
+ ? ((*(longPtr) = (objPtr)->internalRep.longValue), TCL_OK) \
+ : Tcl_GetLongFromObj((interp), (objPtr), (longPtr)))
+
+#if (LONG_MAX == INT_MAX)
+#define TclGetIntFromObj(interp, objPtr, intPtr) \
+ (((objPtr)->typePtr == &tclIntType) \
+ ? ((*(intPtr) = (objPtr)->internalRep.longValue), TCL_OK) \
+ : Tcl_GetIntFromObj((interp), (objPtr), (intPtr)))
+#define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \
+ (((objPtr)->typePtr == &tclIntType) \
+ ? ((*(idxPtr) = (objPtr)->internalRep.longValue), TCL_OK) \
+ : TclGetIntForIndex((interp), (objPtr), (endValue), (idxPtr)))
+#else
+#define TclGetIntFromObj(interp, objPtr, intPtr) \
+ (((objPtr)->typePtr == &tclIntType \
+ && (objPtr)->internalRep.longValue >= -(Tcl_WideInt)(UINT_MAX) \
+ && (objPtr)->internalRep.longValue <= (Tcl_WideInt)(UINT_MAX)) \
+ ? ((*(intPtr) = (objPtr)->internalRep.longValue), TCL_OK) \
+ : Tcl_GetIntFromObj((interp), (objPtr), (intPtr)))
+#define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \
+ (((objPtr)->typePtr == &tclIntType \
+ && (objPtr)->internalRep.longValue >= INT_MIN \
+ && (objPtr)->internalRep.longValue <= INT_MAX) \
+ ? ((*(idxPtr) = (objPtr)->internalRep.longValue), TCL_OK) \
+ : TclGetIntForIndex((interp), (objPtr), (endValue), (idxPtr)))
+#endif
+
+/*
+ * Macro used to save a function call for common uses of
+ * Tcl_GetWideIntFromObj(). The ANSI C "prototype" is:
+ *
+ * MODULE_SCOPE int TclGetWideIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ * Tcl_WideInt *wideIntPtr);
+ */
+
+#ifdef TCL_WIDE_INT_IS_LONG
+#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \
+ (((objPtr)->typePtr == &tclIntType) \
+ ? (*(wideIntPtr) = (Tcl_WideInt) \
+ ((objPtr)->internalRep.longValue), TCL_OK) : \
+ Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr)))
+#else /* !TCL_WIDE_INT_IS_LONG */
+#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \
+ (((objPtr)->typePtr == &tclWideIntType) \
+ ? (*(wideIntPtr) = (objPtr)->internalRep.wideValue, TCL_OK) : \
+ ((objPtr)->typePtr == &tclIntType) \
+ ? (*(wideIntPtr) = (Tcl_WideInt) \
+ ((objPtr)->internalRep.longValue), TCL_OK) : \
+ Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr)))
+#endif /* TCL_WIDE_INT_IS_LONG */
+
+/*
+ * Flag values for TclTraceDictPath().
+ *
+ * DICT_PATH_READ indicates that all entries on the path must exist but no
+ * updates will be needed.
+ *
+ * DICT_PATH_UPDATE indicates that we are going to be doing an update at the
+ * tip of the path, so duplication of shared objects should be done along the
+ * way.
+ *
+ * DICT_PATH_EXISTS indicates that we are performing an existence test and a
+ * lookup failure should therefore not be an error. If (and only if) this flag
+ * is set, TclTraceDictPath() will return the special value
+ * DICT_PATH_NON_EXISTENT if the path is not traceable.
+ *
+ * DICT_PATH_CREATE (which also requires the DICT_PATH_UPDATE bit to be set)
+ * indicates that we are to create non-existent dictionaries on the path.
+ */
+
+#define DICT_PATH_READ 0
+#define DICT_PATH_UPDATE 1
+#define DICT_PATH_EXISTS 2
+#define DICT_PATH_CREATE 5
+
+#define DICT_PATH_NON_EXISTENT ((Tcl_Obj *) (void *) 1)
+
+/*
+ *----------------------------------------------------------------
+ * Data structures related to the filesystem internals
+ *----------------------------------------------------------------
+ */
+
+/*
+ * The version_2 filesystem is private to Tcl. As and when these changes have
+ * been thoroughly tested and investigated a new public filesystem interface
+ * will be released. The aim is more versatile virtual filesystem interfaces,
+ * more efficiency in 'path' manipulation and usage, and cleaner filesystem
+ * code internally.
+ */
+
+#define TCL_FILESYSTEM_VERSION_2 ((Tcl_FSVersion) 0x2)
+typedef ClientData (TclFSGetCwdProc2)(ClientData clientData);
+typedef int (Tcl_FSLoadFileProc2) (Tcl_Interp *interp, Tcl_Obj *pathPtr,
+ Tcl_LoadHandle *handlePtr, Tcl_FSUnloadFileProc **unloadProcPtr, int flags);
+
+/*
+ * The following types are used for getting and storing platform-specific file
+ * attributes in tclFCmd.c and the various platform-versions of that file.
+ * This is done to have as much common code as possible in the file attributes
+ * code. For more information about the callbacks, see TclFileAttrsCmd in
+ * tclFCmd.c.
+ */
+
+typedef int (TclGetFileAttrProc)(Tcl_Interp *interp, int objIndex,
+ Tcl_Obj *fileName, Tcl_Obj **attrObjPtrPtr);
+typedef int (TclSetFileAttrProc)(Tcl_Interp *interp, int objIndex,
+ Tcl_Obj *fileName, Tcl_Obj *attrObjPtr);
+
+typedef struct TclFileAttrProcs {
+ TclGetFileAttrProc *getProc;/* The procedure for getting attrs. */
+ TclSetFileAttrProc *setProc;/* The procedure for setting attrs. */
+} TclFileAttrProcs;
+
+/*
+ * Opaque handle used in pipeline routines to encapsulate platform-dependent
+ * state.
+ */
+
+typedef struct TclFile_ *TclFile;
+
+/*
+ * The "globParameters" argument of the function TclGlob is an or'ed
+ * combination of the following values:
+ */
+
+#define TCL_GLOBMODE_NO_COMPLAIN 1
+#define TCL_GLOBMODE_JOIN 2
+#define TCL_GLOBMODE_DIR 4
+#define TCL_GLOBMODE_TAILS 8
+
+typedef enum Tcl_PathPart {
+ TCL_PATH_DIRNAME,
+ TCL_PATH_TAIL,
+ TCL_PATH_EXTENSION,
+ TCL_PATH_ROOT
+} Tcl_PathPart;
+
+/*
+ *----------------------------------------------------------------
+ * Data structures related to obsolete filesystem hooks
+ *----------------------------------------------------------------
+ */
+
+typedef int (TclStatProc_)(const char *path, struct stat *buf);
+typedef int (TclAccessProc_)(const char *path, int mode);
+typedef Tcl_Channel (TclOpenFileChannelProc_)(Tcl_Interp *interp,
+ const char *fileName, const char *modeString, int permissions);
+
+/*
+ *----------------------------------------------------------------
+ * Data structures related to procedures
+ *----------------------------------------------------------------
+ */
+
+typedef Tcl_CmdProc *TclCmdProcType;
+typedef Tcl_ObjCmdProc *TclObjCmdProcType;
+
+/*
+ *----------------------------------------------------------------
+ * Data structures for process-global values.
+ *----------------------------------------------------------------
+ */
+
+typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, int *lengthPtr,
+ Tcl_Encoding *encodingPtr);
+
+/*
+ * A ProcessGlobalValue struct exists for each internal value in Tcl that is
+ * to be shared among several threads. Each thread sees a (Tcl_Obj) copy of
+ * the value, and the master is kept as a counted string, with epoch and mutex
+ * control. Each ProcessGlobalValue struct should be a static variable in some
+ * file.
+ */
+
+typedef struct ProcessGlobalValue {
+ int epoch; /* Epoch counter to detect changes in the
+ * master value. */
+ int numBytes; /* Length of the master string. */
+ char *value; /* The master string value. */
+ Tcl_Encoding encoding; /* system encoding when master string was
+ * initialized. */
+ TclInitProcessGlobalValueProc *proc;
+ /* A procedure to initialize the master string
+ * copy when a "get" request comes in before
+ * any "set" request has been received. */
+ Tcl_Mutex mutex; /* Enforce orderly access from multiple
+ * threads. */
+ Tcl_ThreadDataKey key; /* Key for per-thread data holding the
+ * (Tcl_Obj) copy for each thread. */
+} ProcessGlobalValue;
+
+/*
+ *----------------------------------------------------------------------
+ * Flags for TclParseNumber
+ *----------------------------------------------------------------------
+ */
+
+#define TCL_PARSE_DECIMAL_ONLY 1
+ /* Leading zero doesn't denote octal or
+ * hex. */
+#define TCL_PARSE_OCTAL_ONLY 2
+ /* Parse octal even without prefix. */
+#define TCL_PARSE_HEXADECIMAL_ONLY 4
+ /* Parse hexadecimal even without prefix. */
+#define TCL_PARSE_INTEGER_ONLY 8
+ /* Disable floating point parsing. */
+#define TCL_PARSE_SCAN_PREFIXES 16
+ /* Use [scan] rules dealing with 0?
+ * prefixes. */
+#define TCL_PARSE_NO_WHITESPACE 32
+ /* Reject leading/trailing whitespace. */
+#define TCL_PARSE_BINARY_ONLY 64
+ /* Parse binary even without prefix. */
+
+/*
+ *----------------------------------------------------------------------
+ * Type values TclGetNumberFromObj
+ *----------------------------------------------------------------------
+ */
+
+#define TCL_NUMBER_LONG 1
+#define TCL_NUMBER_WIDE 2
+#define TCL_NUMBER_BIG 3
+#define TCL_NUMBER_DOUBLE 4
+#define TCL_NUMBER_NAN 5
+
+/*
+ *----------------------------------------------------------------
+ * Variables shared among Tcl modules but not used by the outside world.
+ *----------------------------------------------------------------
+ */
+
+MODULE_SCOPE char *tclNativeExecutableName;
+MODULE_SCOPE int tclFindExecutableSearchDone;
+MODULE_SCOPE char *tclMemDumpFileName;
+MODULE_SCOPE TclPlatformType tclPlatform;
+MODULE_SCOPE Tcl_NotifierProcs tclNotifierHooks;
+
+MODULE_SCOPE Tcl_Encoding tclIdentityEncoding;
+
+/*
+ * TIP #233 (Virtualized Time)
+ * Data for the time hooks, if any.
+ */
+
+MODULE_SCOPE Tcl_GetTimeProc *tclGetTimeProcPtr;
+MODULE_SCOPE Tcl_ScaleTimeProc *tclScaleTimeProcPtr;
+MODULE_SCOPE ClientData tclTimeClientData;
+
+/*
+ * Variables denoting the Tcl object types defined in the core.
+ */
+
+MODULE_SCOPE const Tcl_ObjType tclBignumType;
+MODULE_SCOPE const Tcl_ObjType tclBooleanType;
+MODULE_SCOPE const Tcl_ObjType tclByteArrayType;
+MODULE_SCOPE const Tcl_ObjType tclByteCodeType;
+MODULE_SCOPE const Tcl_ObjType tclDoubleType;
+MODULE_SCOPE const Tcl_ObjType tclEndOffsetType;
+MODULE_SCOPE const Tcl_ObjType tclIntType;
+MODULE_SCOPE const Tcl_ObjType tclListType;
+MODULE_SCOPE const Tcl_ObjType tclDictType;
+MODULE_SCOPE const Tcl_ObjType tclProcBodyType;
+MODULE_SCOPE const Tcl_ObjType tclStringType;
+MODULE_SCOPE const Tcl_ObjType tclArraySearchType;
+MODULE_SCOPE const Tcl_ObjType tclEnsembleCmdType;
+#ifndef TCL_WIDE_INT_IS_LONG
+MODULE_SCOPE const Tcl_ObjType tclWideIntType;
+#endif
+MODULE_SCOPE const Tcl_ObjType tclRegexpType;
+MODULE_SCOPE Tcl_ObjType tclCmdNameType;
+
+/*
+ * Variables denoting the hash key types defined in the core.
+ */
+
+MODULE_SCOPE const Tcl_HashKeyType tclArrayHashKeyType;
+MODULE_SCOPE const Tcl_HashKeyType tclOneWordHashKeyType;
+MODULE_SCOPE const Tcl_HashKeyType tclStringHashKeyType;
+MODULE_SCOPE const Tcl_HashKeyType tclObjHashKeyType;
+
+/*
+ * The head of the list of free Tcl objects, and the total number of Tcl
+ * objects ever allocated and freed.
+ */
+
+MODULE_SCOPE Tcl_Obj * tclFreeObjList;
+
+#ifdef TCL_COMPILE_STATS
+MODULE_SCOPE long tclObjsAlloced;
+MODULE_SCOPE long tclObjsFreed;
+#define TCL_MAX_SHARED_OBJ_STATS 5
+MODULE_SCOPE long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS];
+#endif /* TCL_COMPILE_STATS */
+
+/*
+ * Pointer to a heap-allocated string of length zero that the Tcl core uses as
+ * the value of an empty string representation for an object. This value is
+ * shared by all new objects allocated by Tcl_NewObj.
+ */
+
+MODULE_SCOPE char * tclEmptyStringRep;
+MODULE_SCOPE char tclEmptyString;
+
+/*
+ *----------------------------------------------------------------
+ * Procedures shared among Tcl modules but not used by the outside world,
+ * introduced by/for NRE.
+ *----------------------------------------------------------------
+ */
+
+MODULE_SCOPE Tcl_ObjCmdProc TclNRApplyObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNREvalObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRCatchObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRExprObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRForObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRForeachCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRIfObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRLmapCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRPackageObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRSourceObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRSubstObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRSwitchObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRTryObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRUplevelObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRWhileObjCmd;
+
+MODULE_SCOPE Tcl_NRPostProc TclNRForIterCallback;
+MODULE_SCOPE Tcl_NRPostProc TclNRCoroutineActivateCallback;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRTailcallObjCmd;
+MODULE_SCOPE Tcl_NRPostProc TclNRTailcallEval;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRInvoke;
+MODULE_SCOPE Tcl_NRPostProc TclNRReleaseValues;
+
+MODULE_SCOPE void TclSetTailcall(Tcl_Interp *interp, Tcl_Obj *tailcallPtr);
+MODULE_SCOPE void TclPushTailcallPoint(Tcl_Interp *interp);
+
+/* These two can be considered for the public api */
+MODULE_SCOPE void TclMarkTailcall(Tcl_Interp *interp);
+MODULE_SCOPE void TclSkipTailcall(Tcl_Interp *interp);
+
+/*
+ * This structure holds the data for the various iteration callbacks used to
+ * NRE the 'for' and 'while' commands. We need a separate structure because we
+ * have more than the 4 client data entries we can provide directly thorugh
+ * the callback API. It is the 'word' information which puts us over the
+ * limit. It is needed because the loop body is argument 4 of 'for' and
+ * argument 2 of 'while'. Not providing the correct index confuses the #280
+ * code. We TclSmallAlloc/Free this.
+ */
+
+typedef struct ForIterData {
+ Tcl_Obj *cond; /* Loop condition expression. */
+ Tcl_Obj *body; /* Loop body. */
+ Tcl_Obj *next; /* Loop step script, NULL for 'while'. */
+ const char *msg; /* Error message part. */
+ int word; /* Index of the body script in the command */
+} ForIterData;
+
+/* TIP #357 - Structure doing the bookkeeping of handles for Tcl_LoadFile
+ * and Tcl_FindSymbol. This structure corresponds to an opaque
+ * typedef in tcl.h */
+
+typedef void* TclFindSymbolProc(Tcl_Interp* interp, Tcl_LoadHandle loadHandle,
+ const char* symbol);
+struct Tcl_LoadHandle_ {
+ ClientData clientData; /* Client data is the load handle in the
+ * native filesystem if a module was loaded
+ * there, or an opaque pointer to a structure
+ * for further bookkeeping on load-from-VFS
+ * and load-from-memory */
+ TclFindSymbolProc* findSymbolProcPtr;
+ /* Procedure that resolves symbols in a
+ * loaded module */
+ Tcl_FSUnloadFileProc* unloadFileProcPtr;
+ /* Procedure that unloads a loaded module */
+};
+
+/* Flags for conversion of doubles to digit strings */
+
+#define TCL_DD_SHORTEST 0x4
+ /* Use the shortest possible string */
+#define TCL_DD_STEELE 0x5
+ /* Use the original Steele&White algorithm */
+#define TCL_DD_E_FORMAT 0x2
+ /* Use a fixed-length string of digits,
+ * suitable for E format*/
+#define TCL_DD_F_FORMAT 0x3
+ /* Use a fixed number of digits after the
+ * decimal point, suitable for F format */
+
+#define TCL_DD_SHORTEN_FLAG 0x4
+ /* Allow return of a shorter digit string
+ * if it converts losslessly */
+#define TCL_DD_NO_QUICK 0x8
+ /* Debug flag: forbid quick FP conversion */
+
+#define TCL_DD_CONVERSION_TYPE_MASK 0x3
+ /* Mask to isolate the conversion type */
+#define TCL_DD_STEELE0 0x1
+ /* 'Steele&White' after masking */
+#define TCL_DD_SHORTEST0 0x0
+ /* 'Shortest possible' after masking */
+
+/*
+ *----------------------------------------------------------------
+ * Procedures shared among Tcl modules but not used by the outside world:
+ *----------------------------------------------------------------
+ */
+
+MODULE_SCOPE void TclAppendBytesToByteArray(Tcl_Obj *objPtr,
+ const unsigned char *bytes, int len);
+MODULE_SCOPE int TclNREvalCmd(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ int flags);
+MODULE_SCOPE void TclAdvanceContinuations(int *line, int **next,
+ int loc);
+MODULE_SCOPE void TclAdvanceLines(int *line, const char *start,
+ const char *end);
+MODULE_SCOPE void TclArgumentEnter(Tcl_Interp *interp,
+ Tcl_Obj *objv[], int objc, CmdFrame *cf);
+MODULE_SCOPE void TclArgumentRelease(Tcl_Interp *interp,
+ Tcl_Obj *objv[], int objc);
+MODULE_SCOPE void TclArgumentBCEnter(Tcl_Interp *interp,
+ Tcl_Obj *objv[], int objc,
+ void *codePtr, CmdFrame *cfPtr, int cmd, int pc);
+MODULE_SCOPE void TclArgumentBCRelease(Tcl_Interp *interp,
+ CmdFrame *cfPtr);
+MODULE_SCOPE void TclArgumentGet(Tcl_Interp *interp, Tcl_Obj *obj,
+ CmdFrame **cfPtrPtr, int *wordPtr);
+MODULE_SCOPE int TclArraySet(Tcl_Interp *interp,
+ Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj);
+MODULE_SCOPE double TclBignumToDouble(const mp_int *bignum);
+MODULE_SCOPE int TclByteArrayMatch(const unsigned char *string,
+ int strLen, const unsigned char *pattern,
+ int ptnLen, int flags);
+MODULE_SCOPE double TclCeil(const mp_int *a);
+MODULE_SCOPE void TclChannelPreserve(Tcl_Channel chan);
+MODULE_SCOPE void TclChannelRelease(Tcl_Channel chan);
+MODULE_SCOPE int TclCheckBadOctal(Tcl_Interp *interp,
+ const char *value);
+MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp,
+ Tcl_Channel chan);
+MODULE_SCOPE Tcl_ObjCmdProc TclChannelNamesCmd;
+MODULE_SCOPE Tcl_NRPostProc TclClearRootEnsemble;
+MODULE_SCOPE ContLineLoc *TclContinuationsEnter(Tcl_Obj *objPtr, int num,
+ int *loc);
+MODULE_SCOPE void TclContinuationsEnterDerived(Tcl_Obj *objPtr,
+ int start, int *clNext);
+MODULE_SCOPE ContLineLoc *TclContinuationsGet(Tcl_Obj *objPtr);
+MODULE_SCOPE void TclContinuationsCopy(Tcl_Obj *objPtr,
+ Tcl_Obj *originObjPtr);
+MODULE_SCOPE int TclConvertElement(const char *src, int length,
+ char *dst, int flags);
+MODULE_SCOPE Tcl_Command TclCreateObjCommandInNs (
+ Tcl_Interp *interp,
+ const char *cmdName,
+ Tcl_Namespace *nsPtr,
+ Tcl_ObjCmdProc *proc,
+ ClientData clientData,
+ Tcl_CmdDeleteProc *deleteProc);
+MODULE_SCOPE Tcl_Command TclCreateEnsembleInNs(
+ Tcl_Interp *interp,
+ const char *name,
+ Tcl_Namespace *nameNamespacePtr,
+ Tcl_Namespace *ensembleNamespacePtr,
+ int flags);
+MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr);
+MODULE_SCOPE int TclFindDictElement(Tcl_Interp *interp,
+ const char *dict, int dictLength,
+ const char **elementPtr, const char **nextPtr,
+ int *sizePtr, int *literalPtr);
+/* TIP #280 - Modified token based evulation, with line information. */
+MODULE_SCOPE int TclEvalEx(Tcl_Interp *interp, const char *script,
+ int numBytes, int flags, int line,
+ int *clNextOuter, const char *outerScript);
+MODULE_SCOPE Tcl_ObjCmdProc TclFileAttrsCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclFileCopyCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclFileDeleteCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclFileLinkCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclFileMakeDirsCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclFileReadLinkCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclFileRenameCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclFileTemporaryCmd;
+MODULE_SCOPE void TclCreateLateExitHandler(Tcl_ExitProc *proc,
+ ClientData clientData);
+MODULE_SCOPE void TclDeleteLateExitHandler(Tcl_ExitProc *proc,
+ ClientData clientData);
+MODULE_SCOPE char * TclDStringAppendObj(Tcl_DString *dsPtr,
+ Tcl_Obj *objPtr);
+MODULE_SCOPE char * TclDStringAppendDString(Tcl_DString *dsPtr,
+ Tcl_DString *toAppendPtr);
+MODULE_SCOPE Tcl_Obj * TclDStringToObj(Tcl_DString *dsPtr);
+MODULE_SCOPE Tcl_Obj *const * TclFetchEnsembleRoot(Tcl_Interp *interp,
+ Tcl_Obj *const *objv, int objc, int *objcPtr);
+Tcl_Namespace * TclEnsureNamespace(
+ Tcl_Interp *interp,
+ Tcl_Namespace *namespacePtr);
+
+MODULE_SCOPE void TclFinalizeAllocSubsystem(void);
+MODULE_SCOPE void TclFinalizeAsync(void);
+MODULE_SCOPE void TclFinalizeDoubleConversion(void);
+MODULE_SCOPE void TclFinalizeEncodingSubsystem(void);
+MODULE_SCOPE void TclFinalizeEnvironment(void);
+MODULE_SCOPE void TclFinalizeEvaluation(void);
+MODULE_SCOPE void TclFinalizeExecution(void);
+MODULE_SCOPE void TclFinalizeIOSubsystem(void);
+MODULE_SCOPE void TclFinalizeFilesystem(void);
+MODULE_SCOPE void TclResetFilesystem(void);
+MODULE_SCOPE void TclFinalizeLoad(void);
+MODULE_SCOPE void TclFinalizeLock(void);
+MODULE_SCOPE void TclFinalizeMemorySubsystem(void);
+MODULE_SCOPE void TclFinalizeNotifier(void);
+MODULE_SCOPE void TclFinalizeObjects(void);
+MODULE_SCOPE void TclFinalizePreserve(void);
+MODULE_SCOPE void TclFinalizeSynchronization(void);
+MODULE_SCOPE void TclFinalizeThreadAlloc(void);
+MODULE_SCOPE void TclFinalizeThreadAllocThread(void);
+MODULE_SCOPE void TclFinalizeThreadData(int quick);
+MODULE_SCOPE void TclFinalizeThreadObjects(void);
+MODULE_SCOPE double TclFloor(const mp_int *a);
+MODULE_SCOPE void TclFormatNaN(double value, char *buffer);
+MODULE_SCOPE int TclFSFileAttrIndex(Tcl_Obj *pathPtr,
+ const char *attributeName, int *indexPtr);
+MODULE_SCOPE Tcl_Command TclNRCreateCommandInNs (
+ Tcl_Interp *interp,
+ const char *cmdName,
+ Tcl_Namespace *nsPtr,
+ Tcl_ObjCmdProc *proc,
+ Tcl_ObjCmdProc *nreProc,
+ ClientData clientData,
+ Tcl_CmdDeleteProc *deleteProc);
+
+MODULE_SCOPE int TclNREvalFile(Tcl_Interp *interp, Tcl_Obj *pathPtr,
+ const char *encodingName);
+MODULE_SCOPE void TclFSUnloadTempFile(Tcl_LoadHandle loadHandle);
+MODULE_SCOPE int * TclGetAsyncReadyPtr(void);
+MODULE_SCOPE Tcl_Obj * TclGetBgErrorHandler(Tcl_Interp *interp);
+MODULE_SCOPE int TclGetChannelFromObj(Tcl_Interp *interp,
+ Tcl_Obj *objPtr, Tcl_Channel *chanPtr,
+ int *modePtr, int flags);
+MODULE_SCOPE CmdFrame * TclGetCmdFrameForProcedure(Proc *procPtr);
+MODULE_SCOPE int TclGetCompletionCodeFromObj(Tcl_Interp *interp,
+ Tcl_Obj *value, int *code);
+MODULE_SCOPE int TclGetNumberFromObj(Tcl_Interp *interp,
+ Tcl_Obj *objPtr, ClientData *clientDataPtr,
+ int *typePtr);
+MODULE_SCOPE int TclGetOpenModeEx(Tcl_Interp *interp,
+ const char *modeString, int *seekFlagPtr,
+ int *binaryPtr);
+MODULE_SCOPE Tcl_Obj * TclGetProcessGlobalValue(ProcessGlobalValue *pgvPtr);
+MODULE_SCOPE Tcl_Obj * TclGetSourceFromFrame(CmdFrame *cfPtr, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE char * TclGetStringStorage(Tcl_Obj *objPtr,
+ unsigned int *sizePtr);
+MODULE_SCOPE int TclGlob(Tcl_Interp *interp, char *pattern,
+ Tcl_Obj *unquotedPrefix, int globFlags,
+ Tcl_GlobTypeData *types);
+MODULE_SCOPE int TclIncrObj(Tcl_Interp *interp, Tcl_Obj *valuePtr,
+ Tcl_Obj *incrPtr);
+MODULE_SCOPE Tcl_Obj * TclIncrObjVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
+ Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags);
+MODULE_SCOPE int TclInfoExistsCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+MODULE_SCOPE int TclInfoCoroutineCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_Obj * TclInfoFrame(Tcl_Interp *interp, CmdFrame *framePtr);
+MODULE_SCOPE int TclInfoGlobalsCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+MODULE_SCOPE int TclInfoLocalsCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+MODULE_SCOPE int TclInfoVarsCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+MODULE_SCOPE void TclInitAlloc(void);
+MODULE_SCOPE void TclInitDbCkalloc(void);
+MODULE_SCOPE void TclInitDoubleConversion(void);
+MODULE_SCOPE void TclInitEmbeddedConfigurationInformation(
+ Tcl_Interp *interp);
+MODULE_SCOPE void TclInitEncodingSubsystem(void);
+MODULE_SCOPE void TclInitIOSubsystem(void);
+MODULE_SCOPE void TclInitLimitSupport(Tcl_Interp *interp);
+MODULE_SCOPE void TclInitNamespaceSubsystem(void);
+MODULE_SCOPE void TclInitNotifier(void);
+MODULE_SCOPE void TclInitObjSubsystem(void);
+MODULE_SCOPE void TclInitSubsystems(void);
+MODULE_SCOPE int TclInterpReady(Tcl_Interp *interp);
+MODULE_SCOPE int TclIsSpaceProc(char byte);
+MODULE_SCOPE int TclIsBareword(char byte);
+MODULE_SCOPE Tcl_Obj * TclJoinPath(int elements, Tcl_Obj * const objv[]);
+MODULE_SCOPE int TclJoinThread(Tcl_ThreadId id, int *result);
+MODULE_SCOPE void TclLimitRemoveAllHandlers(Tcl_Interp *interp);
+MODULE_SCOPE Tcl_Obj * TclLindexList(Tcl_Interp *interp,
+ Tcl_Obj *listPtr, Tcl_Obj *argPtr);
+MODULE_SCOPE Tcl_Obj * TclLindexFlat(Tcl_Interp *interp, Tcl_Obj *listPtr,
+ int indexCount, Tcl_Obj *const indexArray[]);
+/* TIP #280 */
+MODULE_SCOPE void TclListLines(Tcl_Obj *listObj, int line, int n,
+ int *lines, Tcl_Obj *const *elems);
+MODULE_SCOPE Tcl_Obj * TclListObjCopy(Tcl_Interp *interp, Tcl_Obj *listPtr);
+MODULE_SCOPE Tcl_Obj * TclLsetList(Tcl_Interp *interp, Tcl_Obj *listPtr,
+ Tcl_Obj *indexPtr, Tcl_Obj *valuePtr);
+MODULE_SCOPE Tcl_Obj * TclLsetFlat(Tcl_Interp *interp, Tcl_Obj *listPtr,
+ int indexCount, Tcl_Obj *const indexArray[],
+ Tcl_Obj *valuePtr);
+MODULE_SCOPE Tcl_Command TclMakeEnsemble(Tcl_Interp *interp, const char *name,
+ const EnsembleImplMap map[]);
+MODULE_SCOPE int TclMaxListLength(const char *bytes, int numBytes,
+ const char **endPtr);
+MODULE_SCOPE int TclMergeReturnOptions(Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[], Tcl_Obj **optionsPtrPtr,
+ int *codePtr, int *levelPtr);
+MODULE_SCOPE Tcl_Obj * TclNoErrorStack(Tcl_Interp *interp, Tcl_Obj *options);
+MODULE_SCOPE int TclNokia770Doubles(void);
+MODULE_SCOPE void TclNsDecrRefCount(Namespace *nsPtr);
+MODULE_SCOPE void TclObjVarErrMsg(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
+ Tcl_Obj *part2Ptr, const char *operation,
+ const char *reason, int index);
+MODULE_SCOPE int TclObjInvokeNamespace(Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[],
+ Tcl_Namespace *nsPtr, int flags);
+MODULE_SCOPE int TclObjUnsetVar2(Tcl_Interp *interp,
+ Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags);
+MODULE_SCOPE int TclParseBackslash(const char *src,
+ int numBytes, int *readPtr, char *dst);
+MODULE_SCOPE int TclParseHex(const char *src, int numBytes,
+ int *resultPtr);
+MODULE_SCOPE int TclParseNumber(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ const char *expected, const char *bytes,
+ int numBytes, const char **endPtrPtr, int flags);
+MODULE_SCOPE void TclParseInit(Tcl_Interp *interp, const char *string,
+ int numBytes, Tcl_Parse *parsePtr);
+MODULE_SCOPE int TclParseAllWhiteSpace(const char *src, int numBytes);
+MODULE_SCOPE int TclProcessReturn(Tcl_Interp *interp,
+ int code, int level, Tcl_Obj *returnOpts);
+MODULE_SCOPE int TclpObjLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf);
+MODULE_SCOPE Tcl_Obj * TclpTempFileName(void);
+MODULE_SCOPE Tcl_Obj * TclpTempFileNameForLibrary(Tcl_Interp *interp, Tcl_Obj* pathPtr);
+MODULE_SCOPE Tcl_Obj * TclNewFSPathObj(Tcl_Obj *dirPtr, const char *addStrRep,
+ int len);
+MODULE_SCOPE int TclpDeleteFile(const void *path);
+MODULE_SCOPE void TclpFinalizeCondition(Tcl_Condition *condPtr);
+MODULE_SCOPE void TclpFinalizeMutex(Tcl_Mutex *mutexPtr);
+MODULE_SCOPE void TclpFinalizePipes(void);
+MODULE_SCOPE void TclpFinalizeSockets(void);
+MODULE_SCOPE int TclCreateSocketAddress(Tcl_Interp *interp,
+ struct addrinfo **addrlist,
+ const char *host, int port, int willBind,
+ const char **errorMsgPtr);
+MODULE_SCOPE int TclpThreadCreate(Tcl_ThreadId *idPtr,
+ Tcl_ThreadCreateProc *proc, ClientData clientData,
+ int stackSize, int flags);
+MODULE_SCOPE int TclpFindVariable(const char *name, int *lengthPtr);
+MODULE_SCOPE void TclpInitLibraryPath(char **valuePtr,
+ int *lengthPtr, Tcl_Encoding *encodingPtr);
+MODULE_SCOPE void TclpInitLock(void);
+MODULE_SCOPE void TclpInitPlatform(void);
+MODULE_SCOPE void TclpInitUnlock(void);
+MODULE_SCOPE Tcl_Obj * TclpObjListVolumes(void);
+MODULE_SCOPE void TclpMasterLock(void);
+MODULE_SCOPE void TclpMasterUnlock(void);
+MODULE_SCOPE int TclpMatchFiles(Tcl_Interp *interp, char *separators,
+ Tcl_DString *dirPtr, char *pattern, char *tail);
+MODULE_SCOPE int TclpObjNormalizePath(Tcl_Interp *interp,
+ Tcl_Obj *pathPtr, int nextCheckpoint);
+MODULE_SCOPE void TclpNativeJoinPath(Tcl_Obj *prefix, const char *joining);
+MODULE_SCOPE Tcl_Obj * TclpNativeSplitPath(Tcl_Obj *pathPtr, int *lenPtr);
+MODULE_SCOPE Tcl_PathType TclpGetNativePathType(Tcl_Obj *pathPtr,
+ int *driveNameLengthPtr, Tcl_Obj **driveNameRef);
+MODULE_SCOPE int TclCrossFilesystemCopy(Tcl_Interp *interp,
+ Tcl_Obj *source, Tcl_Obj *target);
+MODULE_SCOPE int TclpMatchInDirectory(Tcl_Interp *interp,
+ Tcl_Obj *resultPtr, Tcl_Obj *pathPtr,
+ const char *pattern, Tcl_GlobTypeData *types);
+MODULE_SCOPE ClientData TclpGetNativeCwd(ClientData clientData);
+MODULE_SCOPE Tcl_FSDupInternalRepProc TclNativeDupInternalRep;
+MODULE_SCOPE Tcl_Obj * TclpObjLink(Tcl_Obj *pathPtr, Tcl_Obj *toPtr,
+ int linkType);
+MODULE_SCOPE int TclpObjChdir(Tcl_Obj *pathPtr);
+MODULE_SCOPE Tcl_Channel TclpOpenTemporaryFile(Tcl_Obj *dirObj,
+ Tcl_Obj *basenameObj, Tcl_Obj *extensionObj,
+ Tcl_Obj *resultingNameObj);
+MODULE_SCOPE Tcl_Obj * TclPathPart(Tcl_Interp *interp, Tcl_Obj *pathPtr,
+ Tcl_PathPart portion);
+MODULE_SCOPE char * TclpReadlink(const char *fileName,
+ Tcl_DString *linkPtr);
+MODULE_SCOPE void TclpSetInterfaces(void);
+MODULE_SCOPE void TclpSetVariables(Tcl_Interp *interp);
+MODULE_SCOPE void * TclThreadStorageKeyGet(Tcl_ThreadDataKey *keyPtr);
+MODULE_SCOPE void TclThreadStorageKeySet(Tcl_ThreadDataKey *keyPtr,
+ void *data);
+MODULE_SCOPE void TclpThreadExit(int status);
+MODULE_SCOPE void TclRememberCondition(Tcl_Condition *mutex);
+MODULE_SCOPE void TclRememberJoinableThread(Tcl_ThreadId id);
+MODULE_SCOPE void TclRememberMutex(Tcl_Mutex *mutex);
+MODULE_SCOPE void TclRemoveScriptLimitCallbacks(Tcl_Interp *interp);
+MODULE_SCOPE int TclReToGlob(Tcl_Interp *interp, const char *reStr,
+ int reStrLen, Tcl_DString *dsPtr, int *flagsPtr,
+ int *quantifiersFoundPtr);
+MODULE_SCOPE int TclScanElement(const char *string, int length,
+ char *flagPtr);
+MODULE_SCOPE void TclSetBgErrorHandler(Tcl_Interp *interp,
+ Tcl_Obj *cmdPrefix);
+MODULE_SCOPE void TclSetBignumIntRep(Tcl_Obj *objPtr,
+ mp_int *bignumValue);
+MODULE_SCOPE int TclSetBooleanFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
+MODULE_SCOPE void TclSetCmdNameObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ Command *cmdPtr);
+MODULE_SCOPE void TclSetDuplicateObj(Tcl_Obj *dupPtr, Tcl_Obj *objPtr);
+MODULE_SCOPE void TclSetProcessGlobalValue(ProcessGlobalValue *pgvPtr,
+ Tcl_Obj *newValue, Tcl_Encoding encoding);
+MODULE_SCOPE void TclSignalExitThread(Tcl_ThreadId id, int result);
+MODULE_SCOPE void TclSpellFix(Tcl_Interp *interp,
+ Tcl_Obj *const *objv, int objc, int subIdx,
+ Tcl_Obj *bad, Tcl_Obj *fix);
+MODULE_SCOPE void * TclStackRealloc(Tcl_Interp *interp, void *ptr,
+ int numBytes);
+MODULE_SCOPE int TclStringMatch(const char *str, int strLen,
+ const char *pattern, int ptnLen, int flags);
+MODULE_SCOPE int TclStringMatchObj(Tcl_Obj *stringObj,
+ Tcl_Obj *patternObj, int flags);
+MODULE_SCOPE Tcl_Obj * TclStringObjReverse(Tcl_Obj *objPtr);
+MODULE_SCOPE void TclSubstCompile(Tcl_Interp *interp, const char *bytes,
+ int numBytes, int flags, int line,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclSubstOptions(Tcl_Interp *interp, int numOpts,
+ Tcl_Obj *const opts[], int *flagPtr);
+MODULE_SCOPE void TclSubstParse(Tcl_Interp *interp, const char *bytes,
+ int numBytes, int flags, Tcl_Parse *parsePtr,
+ Tcl_InterpState *statePtr);
+MODULE_SCOPE int TclSubstTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr,
+ int count, int *tokensLeftPtr, int line,
+ int *clNextOuter, const char *outerScript);
+MODULE_SCOPE int TclTrimLeft(const char *bytes, int numBytes,
+ const char *trim, int numTrim);
+MODULE_SCOPE int TclTrimRight(const char *bytes, int numBytes,
+ const char *trim, int numTrim);
+MODULE_SCOPE int TclUtfCasecmp(const char *cs, const char *ct);
+MODULE_SCOPE Tcl_Obj * TclpNativeToNormalized(ClientData clientData);
+MODULE_SCOPE Tcl_Obj * TclpFilesystemPathType(Tcl_Obj *pathPtr);
+MODULE_SCOPE int TclpDlopen(Tcl_Interp *interp, Tcl_Obj *pathPtr,
+ Tcl_LoadHandle *loadHandle,
+ Tcl_FSUnloadFileProc **unloadProcPtr, int flags);
+MODULE_SCOPE int TclpUtime(Tcl_Obj *pathPtr, struct utimbuf *tval);
+#ifdef TCL_LOAD_FROM_MEMORY
+MODULE_SCOPE void * TclpLoadMemoryGetBuffer(Tcl_Interp *interp, int size);
+MODULE_SCOPE int TclpLoadMemory(Tcl_Interp *interp, void *buffer,
+ int size, int codeSize, Tcl_LoadHandle *loadHandle,
+ Tcl_FSUnloadFileProc **unloadProcPtr, int flags);
+#endif
+MODULE_SCOPE void TclInitThreadStorage(void);
+MODULE_SCOPE void TclFinalizeThreadDataThread(void);
+MODULE_SCOPE void TclFinalizeThreadStorage(void);
+#ifdef TCL_WIDE_CLICKS
+MODULE_SCOPE Tcl_WideInt TclpGetWideClicks(void);
+MODULE_SCOPE double TclpWideClicksToNanoseconds(Tcl_WideInt clicks);
+#endif
+MODULE_SCOPE int TclZlibInit(Tcl_Interp *interp);
+MODULE_SCOPE void * TclpThreadCreateKey(void);
+MODULE_SCOPE void TclpThreadDeleteKey(void *keyPtr);
+MODULE_SCOPE void TclpThreadSetMasterTSD(void *tsdKeyPtr, void *ptr);
+MODULE_SCOPE void * TclpThreadGetMasterTSD(void *tsdKeyPtr);
+
+MODULE_SCOPE void TclErrorStackResetIf(Tcl_Interp *interp, const char *msg, int length);
+
+/*
+ *----------------------------------------------------------------
+ * Command procedures in the generic core:
+ *----------------------------------------------------------------
+ */
+
+MODULE_SCOPE int Tcl_AfterObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_AppendObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_ApplyObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_Command TclInitArrayCmd(Tcl_Interp *interp);
+MODULE_SCOPE Tcl_Command TclInitBinaryCmd(Tcl_Interp *interp);
+MODULE_SCOPE int Tcl_BreakObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_CaseObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_CatchObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_CdObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_Command TclInitChanCmd(Tcl_Interp *interp);
+MODULE_SCOPE int TclChanCreateObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int TclChanPostEventObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int TclChanPopObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
+MODULE_SCOPE int TclChanPushObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
+MODULE_SCOPE void TclClockInit(Tcl_Interp *interp);
+MODULE_SCOPE int TclClockOldscanObjCmd(
+ ClientData clientData, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_CloseObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_ConcatObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_ContinueObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_TimerToken TclCreateAbsoluteTimerHandler(
+ Tcl_Time *timePtr, Tcl_TimerProc *proc,
+ ClientData clientData);
+MODULE_SCOPE int TclDefaultBgErrorHandlerObjCmd(
+ ClientData clientData, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_Command TclInitDictCmd(Tcl_Interp *interp);
+MODULE_SCOPE int TclDictWithFinish(Tcl_Interp *interp, Var *varPtr,
+ Var *arrayPtr, Tcl_Obj *part1Ptr,
+ Tcl_Obj *part2Ptr, int index, int pathc,
+ Tcl_Obj *const pathv[], Tcl_Obj *keysPtr);
+MODULE_SCOPE Tcl_Obj * TclDictWithInit(Tcl_Interp *interp, Tcl_Obj *dictPtr,
+ int pathc, Tcl_Obj *const pathv[]);
+MODULE_SCOPE int Tcl_DisassembleObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+
+/* Assemble command function */
+MODULE_SCOPE int Tcl_AssembleObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int TclNRAssembleObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_Command TclInitEncodingCmd(Tcl_Interp *interp);
+MODULE_SCOPE int TclMakeEncodingCommandSafe(Tcl_Interp *interp);
+MODULE_SCOPE int Tcl_EofObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_ErrorObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_EvalObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_ExecObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_ExitObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_ExprObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_FblockedObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_FconfigureObjCmd(
+ ClientData clientData, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_FcopyObjCmd(ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_Command TclInitFileCmd(Tcl_Interp *interp);
+MODULE_SCOPE int TclMakeFileCommandSafe(Tcl_Interp *interp);
+MODULE_SCOPE int Tcl_FileEventObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_FlushObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_ForObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_ForeachObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_FormatObjCmd(ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_GetsObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_GlobalObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_GlobObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_IfObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_IncrObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_Command TclInitInfoCmd(Tcl_Interp *interp);
+MODULE_SCOPE int Tcl_InterpObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int argc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_JoinObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_LappendObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_LassignObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_LindexObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_LinsertObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_LlengthObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_ListObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_LmapObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_LoadObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_LrangeObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_LrepeatObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_LreplaceObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_LreverseObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_LsearchObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_LsetObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_LsortObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_Command TclInitNamespaceCmd(Tcl_Interp *interp);
+MODULE_SCOPE int TclNamespaceEnsembleCmd(ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_OpenObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_PackageObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_PidObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_Command TclInitPrefixCmd(Tcl_Interp *interp);
+MODULE_SCOPE int Tcl_PutsObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_PwdObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_ReadObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_RegexpObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_RegsubObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_RenameObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_RepresentationCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_ReturnObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_ScanObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_SeekObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_SetObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_SplitObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_SocketObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_SourceObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_Command TclInitStringCmd(Tcl_Interp *interp);
+MODULE_SCOPE int Tcl_SubstObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_SwitchObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_TellObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_ThrowObjCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_TimeObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_TraceObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_TryObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_UnloadObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_UnsetObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_UpdateObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_UplevelObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_UpvarObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_VariableObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_VwaitObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_WhileObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+
+/*
+ *----------------------------------------------------------------
+ * Compilation procedures for commands in the generic core:
+ *----------------------------------------------------------------
+ */
+
+MODULE_SCOPE int TclCompileAppendCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileArrayExistsCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileArraySetCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileArrayUnsetCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileBreakCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileCatchCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileClockClicksCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileClockReadingCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileConcatCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileContinueCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileDictAppendCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileDictCreateCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileDictExistsCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileDictForCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileDictGetCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileDictIncrCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileDictLappendCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileDictMapCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileDictMergeCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileDictSetCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileDictUnsetCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileDictUpdateCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileDictWithCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileEnsemble(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileErrorCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileExprCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileForCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileForeachCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileFormatCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileGlobalCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileIfCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileInfoCommandsCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileInfoCoroutineCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileInfoExistsCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileInfoLevelCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileInfoObjectClassCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileInfoObjectIsACmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileInfoObjectNamespaceCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileIncrCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileLappendCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileLassignCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileLindexCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileLinsertCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileListCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileLlengthCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileLmapCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileLrangeCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileLreplaceCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileLsetCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileNamespaceCodeCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileNamespaceCurrentCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileNamespaceOriginCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileNamespaceQualifiersCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileNamespaceTailCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileNamespaceUpvarCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileNamespaceWhichCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileNoOp(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileObjectNextCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileObjectNextToCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileObjectSelfCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileRegexpCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileRegsubCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileReturnCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileSetCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileStringCatCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileStringCmpCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileStringEqualCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileStringFirstCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileStringIndexCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileStringIsCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileStringLastCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileStringLenCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileStringMapCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileStringMatchCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileStringRangeCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileStringReplaceCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileStringToLowerCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileStringToTitleCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileStringToUpperCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileStringTrimCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileStringTrimLCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileStringTrimRCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileSubstCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileSwitchCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileTailcallCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileThrowCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileTryCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileUnsetCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileUpvarCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileVariableCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileWhileCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileYieldCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileYieldToCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileBasic0ArgCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileBasic1ArgCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileBasic2ArgCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileBasic3ArgCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileBasic0Or1ArgCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileBasic1Or2ArgCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileBasic2Or3ArgCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileBasic0To2ArgCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileBasic1To3ArgCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileBasicMin0ArgCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileBasicMin1ArgCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileBasicMin2ArgCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+
+MODULE_SCOPE int TclInvertOpCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int TclCompileInvertOpCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclNotOpCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int TclCompileNotOpCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclAddOpCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int TclCompileAddOpCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclMulOpCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int TclCompileMulOpCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclAndOpCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int TclCompileAndOpCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclOrOpCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int TclCompileOrOpCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclXorOpCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int TclCompileXorOpCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclPowOpCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int TclCompilePowOpCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclLshiftOpCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int TclCompileLshiftOpCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclRshiftOpCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int TclCompileRshiftOpCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclModOpCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int TclCompileModOpCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclNeqOpCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int TclCompileNeqOpCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclStrneqOpCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int TclCompileStrneqOpCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclInOpCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int TclCompileInOpCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclNiOpCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int TclCompileNiOpCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclMinusOpCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int TclCompileMinusOpCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclDivOpCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int TclCompileDivOpCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclLessOpCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int TclCompileLessOpCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclLeqOpCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int TclCompileLeqOpCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclGreaterOpCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int TclCompileGreaterOpCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclGeqOpCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int TclCompileGeqOpCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclEqOpCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int TclCompileEqOpCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclStreqOpCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+MODULE_SCOPE int TclCompileStreqOpCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+
+MODULE_SCOPE int TclCompileAssembleCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+
+/*
+ * Functions defined in generic/tclVar.c and currently exported only for use
+ * by the bytecode compiler and engine. Some of these could later be placed in
+ * the public interface.
+ */
+
+MODULE_SCOPE Var * TclObjLookupVarEx(Tcl_Interp * interp,
+ Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags,
+ const char *msg, const int createPart1,
+ const int createPart2, Var **arrayPtrPtr);
+MODULE_SCOPE Var * TclLookupArrayElement(Tcl_Interp *interp,
+ Tcl_Obj *arrayNamePtr, Tcl_Obj *elNamePtr,
+ const int flags, const char *msg,
+ const int createPart1, const int createPart2,
+ Var *arrayPtr, int index);
+MODULE_SCOPE Tcl_Obj * TclPtrGetVarIdx(Tcl_Interp *interp,
+ Var *varPtr, Var *arrayPtr, Tcl_Obj *part1Ptr,
+ Tcl_Obj *part2Ptr, const int flags, int index);
+MODULE_SCOPE Tcl_Obj * TclPtrSetVarIdx(Tcl_Interp *interp,
+ Var *varPtr, Var *arrayPtr, Tcl_Obj *part1Ptr,
+ Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr,
+ const int flags, int index);
+MODULE_SCOPE Tcl_Obj * TclPtrIncrObjVarIdx(Tcl_Interp *interp,
+ Var *varPtr, Var *arrayPtr, Tcl_Obj *part1Ptr,
+ Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr,
+ const int flags, int index);
+MODULE_SCOPE int TclPtrObjMakeUpvarIdx(Tcl_Interp *interp,
+ Var *otherPtr, Tcl_Obj *myNamePtr, int myFlags,
+ int index);
+MODULE_SCOPE int TclPtrUnsetVarIdx(Tcl_Interp *interp, Var *varPtr,
+ Var *arrayPtr, Tcl_Obj *part1Ptr,
+ Tcl_Obj *part2Ptr, const int flags,
+ int index);
+MODULE_SCOPE void TclInvalidateNsPath(Namespace *nsPtr);
+MODULE_SCOPE void TclFindArrayPtrElements(Var *arrayPtr,
+ Tcl_HashTable *tablePtr);
+
+/*
+ * The new extended interface to the variable traces.
+ */
+
+MODULE_SCOPE int TclObjCallVarTraces(Interp *iPtr, Var *arrayPtr,
+ Var *varPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr,
+ int flags, int leaveErrMsg, int index);
+
+/*
+ * So tclObj.c and tclDictObj.c can share these implementations.
+ */
+
+MODULE_SCOPE int TclCompareObjKeys(void *keyPtr, Tcl_HashEntry *hPtr);
+MODULE_SCOPE void TclFreeObjEntry(Tcl_HashEntry *hPtr);
+MODULE_SCOPE unsigned TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr);
+
+MODULE_SCOPE int TclFullFinalizationRequested(void);
+
+/*
+ *----------------------------------------------------------------
+ * Macros used by the Tcl core to create and release Tcl objects.
+ * TclNewObj(objPtr) creates a new object denoting an empty string.
+ * TclDecrRefCount(objPtr) decrements the object's reference count, and frees
+ * the object if its reference count is zero. These macros are inline versions
+ * of Tcl_NewObj() and Tcl_DecrRefCount(). Notice that the names differ in not
+ * having a "_" after the "Tcl". Notice also that these macros reference their
+ * argument more than once, so you should avoid calling them with an
+ * expression that is expensive to compute or has side effects. The ANSI C
+ * "prototypes" for these macros are:
+ *
+ * MODULE_SCOPE void TclNewObj(Tcl_Obj *objPtr);
+ * MODULE_SCOPE void TclDecrRefCount(Tcl_Obj *objPtr);
+ *
+ * These macros are defined in terms of two macros that depend on memory
+ * allocator in use: TclAllocObjStorage, TclFreeObjStorage. They are defined
+ * below.
+ *----------------------------------------------------------------
+ */
+
+/*
+ * DTrace object allocation probe macros.
+ */
+
+#ifdef USE_DTRACE
+#ifndef _TCLDTRACE_H
+typedef const char *TclDTraceStr;
+#include "tclDTrace.h"
+#endif
+#define TCL_DTRACE_OBJ_CREATE(objPtr) TCL_OBJ_CREATE(objPtr)
+#define TCL_DTRACE_OBJ_FREE(objPtr) TCL_OBJ_FREE(objPtr)
+#else /* USE_DTRACE */
+#define TCL_DTRACE_OBJ_CREATE(objPtr) {}
+#define TCL_DTRACE_OBJ_FREE(objPtr) {}
+#endif /* USE_DTRACE */
+
+#ifdef TCL_COMPILE_STATS
+# define TclIncrObjsAllocated() \
+ tclObjsAlloced++
+# define TclIncrObjsFreed() \
+ tclObjsFreed++
+#else
+# define TclIncrObjsAllocated()
+# define TclIncrObjsFreed()
+#endif /* TCL_COMPILE_STATS */
+
+# define TclAllocObjStorage(objPtr) \
+ TclAllocObjStorageEx(NULL, (objPtr))
+
+# define TclFreeObjStorage(objPtr) \
+ TclFreeObjStorageEx(NULL, (objPtr))
+
+#ifndef TCL_MEM_DEBUG
+# define TclNewObj(objPtr) \
+ TclIncrObjsAllocated(); \
+ TclAllocObjStorage(objPtr); \
+ (objPtr)->refCount = 0; \
+ (objPtr)->bytes = tclEmptyStringRep; \
+ (objPtr)->length = 0; \
+ (objPtr)->typePtr = NULL; \
+ TCL_DTRACE_OBJ_CREATE(objPtr)
+
+/*
+ * Invalidate the string rep first so we can use the bytes value for our
+ * pointer chain, and signal an obj deletion (as opposed to shimmering) with
+ * 'length == -1'.
+ * Use empty 'if ; else' to handle use in unbraced outer if/else conditions.
+ */
+
+# define TclDecrRefCount(objPtr) \
+ if ((objPtr)->refCount-- > 1) ; else { \
+ if (!(objPtr)->typePtr || !(objPtr)->typePtr->freeIntRepProc) { \
+ TCL_DTRACE_OBJ_FREE(objPtr); \
+ if ((objPtr)->bytes \
+ && ((objPtr)->bytes != tclEmptyStringRep)) { \
+ ckfree((char *) (objPtr)->bytes); \
+ } \
+ (objPtr)->length = -1; \
+ TclFreeObjStorage(objPtr); \
+ TclIncrObjsFreed(); \
+ } else { \
+ TclFreeObj(objPtr); \
+ } \
+ }
+
+#if defined(PURIFY)
+
+/*
+ * The PURIFY mode is like the regular mode, but instead of doing block
+ * Tcl_Obj allocation and keeping a freed list for efficiency, it always
+ * allocates and frees a single Tcl_Obj so that tools like Purify can better
+ * track memory leaks.
+ */
+
+# define TclAllocObjStorageEx(interp, objPtr) \
+ (objPtr) = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj))
+
+# define TclFreeObjStorageEx(interp, objPtr) \
+ ckfree((char *) (objPtr))
+
+#undef USE_THREAD_ALLOC
+#undef USE_TCLALLOC
+#elif defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
+
+/*
+ * The TCL_THREADS mode is like the regular mode but allocates Tcl_Obj's from
+ * per-thread caches.
+ */
+
+MODULE_SCOPE Tcl_Obj * TclThreadAllocObj(void);
+MODULE_SCOPE void TclThreadFreeObj(Tcl_Obj *);
+MODULE_SCOPE Tcl_Mutex *TclpNewAllocMutex(void);
+MODULE_SCOPE void TclFreeAllocCache(void *);
+MODULE_SCOPE void * TclpGetAllocCache(void);
+MODULE_SCOPE void TclpSetAllocCache(void *);
+MODULE_SCOPE void TclpFreeAllocMutex(Tcl_Mutex *mutex);
+MODULE_SCOPE void TclpFreeAllocCache(void *);
+
+/*
+ * These macros need to be kept in sync with the code of TclThreadAllocObj()
+ * and TclThreadFreeObj().
+ *
+ * Note that the optimiser should resolve the case (interp==NULL) at compile
+ * time.
+ */
+
+# define ALLOC_NOBJHIGH 1200
+
+# define TclAllocObjStorageEx(interp, objPtr) \
+ do { \
+ AllocCache *cachePtr; \
+ if (((interp) == NULL) || \
+ ((cachePtr = ((Interp *)(interp))->allocCache), \
+ (cachePtr->numObjects == 0))) { \
+ (objPtr) = TclThreadAllocObj(); \
+ } else { \
+ (objPtr) = cachePtr->firstObjPtr; \
+ cachePtr->firstObjPtr = (objPtr)->internalRep.twoPtrValue.ptr1; \
+ --cachePtr->numObjects; \
+ } \
+ } while (0)
+
+# define TclFreeObjStorageEx(interp, objPtr) \
+ do { \
+ AllocCache *cachePtr; \
+ if (((interp) == NULL) || \
+ ((cachePtr = ((Interp *)(interp))->allocCache), \
+ ((cachePtr->numObjects == 0) || \
+ (cachePtr->numObjects >= ALLOC_NOBJHIGH)))) { \
+ TclThreadFreeObj(objPtr); \
+ } else { \
+ (objPtr)->internalRep.twoPtrValue.ptr1 = cachePtr->firstObjPtr; \
+ cachePtr->firstObjPtr = objPtr; \
+ ++cachePtr->numObjects; \
+ } \
+ } while (0)
+
+#else /* not PURIFY or USE_THREAD_ALLOC */
+
+#if defined(USE_TCLALLOC) && USE_TCLALLOC
+ MODULE_SCOPE void TclFinalizeAllocSubsystem();
+ MODULE_SCOPE void TclInitAlloc();
+#else
+# define USE_TCLALLOC 0
+#endif
+
+#ifdef TCL_THREADS
+/* declared in tclObj.c */
+MODULE_SCOPE Tcl_Mutex tclObjMutex;
+#endif
+
+# define TclAllocObjStorageEx(interp, objPtr) \
+ do { \
+ Tcl_MutexLock(&tclObjMutex); \
+ if (tclFreeObjList == NULL) { \
+ TclAllocateFreeObjects(); \
+ } \
+ (objPtr) = tclFreeObjList; \
+ tclFreeObjList = (Tcl_Obj *) \
+ tclFreeObjList->internalRep.twoPtrValue.ptr1; \
+ Tcl_MutexUnlock(&tclObjMutex); \
+ } while (0)
+
+# define TclFreeObjStorageEx(interp, objPtr) \
+ do { \
+ Tcl_MutexLock(&tclObjMutex); \
+ (objPtr)->internalRep.twoPtrValue.ptr1 = (void *) tclFreeObjList; \
+ tclFreeObjList = (objPtr); \
+ Tcl_MutexUnlock(&tclObjMutex); \
+ } while (0)
+#endif
+
+#else /* TCL_MEM_DEBUG */
+MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
+ int line);
+
+# define TclDbNewObj(objPtr, file, line) \
+ do { \
+ TclIncrObjsAllocated(); \
+ (objPtr) = (Tcl_Obj *) \
+ Tcl_DbCkalloc(sizeof(Tcl_Obj), (file), (line)); \
+ TclDbInitNewObj((objPtr), (file), (line)); \
+ TCL_DTRACE_OBJ_CREATE(objPtr); \
+ } while (0)
+
+# define TclNewObj(objPtr) \
+ TclDbNewObj(objPtr, __FILE__, __LINE__);
+
+# define TclDecrRefCount(objPtr) \
+ Tcl_DbDecrRefCount(objPtr, __FILE__, __LINE__)
+
+# define TclNewListObjDirect(objc, objv) \
+ TclDbNewListObjDirect(objc, objv, __FILE__, __LINE__)
+
+#undef USE_THREAD_ALLOC
+#endif /* TCL_MEM_DEBUG */
+
+/*
+ *----------------------------------------------------------------
+ * Macro used by the Tcl core to set a Tcl_Obj's string representation to a
+ * copy of the "len" bytes starting at "bytePtr". This code works even if the
+ * byte array contains NULLs as long as the length is correct. Because "len"
+ * is referenced multiple times, it should be as simple an expression as
+ * possible. The ANSI C "prototype" for this macro is:
+ *
+ * MODULE_SCOPE void TclInitStringRep(Tcl_Obj *objPtr, char *bytePtr, int len);
+ *
+ * This macro should only be called on an unshared objPtr where
+ * objPtr->typePtr->freeIntRepProc == NULL
+ *----------------------------------------------------------------
+ */
+
+#define TclInitStringRep(objPtr, bytePtr, len) \
+ if ((len) == 0) { \
+ (objPtr)->bytes = tclEmptyStringRep; \
+ (objPtr)->length = 0; \
+ } else { \
+ (objPtr)->bytes = (char *) ckalloc((unsigned) ((len) + 1)); \
+ memcpy((objPtr)->bytes, (bytePtr), (unsigned) (len)); \
+ (objPtr)->bytes[len] = '\0'; \
+ (objPtr)->length = (len); \
+ }
+
+/*
+ *----------------------------------------------------------------
+ * Macro used by the Tcl core to get the string representation's byte array
+ * pointer from a Tcl_Obj. This is an inline version of Tcl_GetString(). The
+ * macro's expression result is the string rep's byte pointer which might be
+ * NULL. The bytes referenced by this pointer must not be modified by the
+ * caller. The ANSI C "prototype" for this macro is:
+ *
+ * MODULE_SCOPE char * TclGetString(Tcl_Obj *objPtr);
+ *----------------------------------------------------------------
+ */
+
+#define TclGetString(objPtr) \
+ ((objPtr)->bytes? (objPtr)->bytes : Tcl_GetString((objPtr)))
+
+#define TclGetStringFromObj(objPtr, lenPtr) \
+ ((objPtr)->bytes \
+ ? (*(lenPtr) = (objPtr)->length, (objPtr)->bytes) \
+ : Tcl_GetStringFromObj((objPtr), (lenPtr)))
+
+/*
+ *----------------------------------------------------------------
+ * Macro used by the Tcl core to clean out an object's internal
+ * representation. Does not actually reset the rep's bytes. The ANSI C
+ * "prototype" for this macro is:
+ *
+ * MODULE_SCOPE void TclFreeIntRep(Tcl_Obj *objPtr);
+ *----------------------------------------------------------------
+ */
+
+#define TclFreeIntRep(objPtr) \
+ if ((objPtr)->typePtr != NULL) { \
+ if ((objPtr)->typePtr->freeIntRepProc != NULL) { \
+ (objPtr)->typePtr->freeIntRepProc(objPtr); \
+ } \
+ (objPtr)->typePtr = NULL; \
+ }
+
+/*
+ *----------------------------------------------------------------
+ * Macro used by the Tcl core to clean out an object's string representation.
+ * The ANSI C "prototype" for this macro is:
+ *
+ * MODULE_SCOPE void TclInvalidateStringRep(Tcl_Obj *objPtr);
+ *----------------------------------------------------------------
+ */
+
+#define TclInvalidateStringRep(objPtr) \
+ if (objPtr->bytes != NULL) { \
+ if (objPtr->bytes != tclEmptyStringRep) { \
+ ckfree((char *) objPtr->bytes); \
+ } \
+ objPtr->bytes = NULL; \
+ }
+
+/*
+ *----------------------------------------------------------------
+ * Macros used by the Tcl core to grow Tcl_Token arrays. They use the same
+ * growth algorithm as used in tclStringObj.c for growing strings. The ANSI C
+ * "prototype" for this macro is:
+ *
+ * MODULE_SCOPE void TclGrowTokenArray(Tcl_Token *tokenPtr, int used,
+ * int available, int append,
+ * Tcl_Token *staticPtr);
+ * MODULE_SCOPE void TclGrowParseTokenArray(Tcl_Parse *parsePtr,
+ * int append);
+ *----------------------------------------------------------------
+ */
+
+/* General tuning for minimum growth in Tcl growth algorithms */
+#ifndef TCL_MIN_GROWTH
+# ifdef TCL_GROWTH_MIN_ALLOC
+ /* Support for any legacy tuners */
+# define TCL_MIN_GROWTH TCL_GROWTH_MIN_ALLOC
+# else
+# define TCL_MIN_GROWTH 1024
+# endif
+#endif
+
+/* Token growth tuning, default to the general value. */
+#ifndef TCL_MIN_TOKEN_GROWTH
+#define TCL_MIN_TOKEN_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_Token)
+#endif
+
+#define TCL_MAX_TOKENS (int)(UINT_MAX / sizeof(Tcl_Token))
+#define TclGrowTokenArray(tokenPtr, used, available, append, staticPtr) \
+ do { \
+ int _needed = (used) + (append); \
+ if (_needed > TCL_MAX_TOKENS) { \
+ Tcl_Panic("max # of tokens for a Tcl parse (%d) exceeded", \
+ TCL_MAX_TOKENS); \
+ } \
+ if (_needed > (available)) { \
+ int allocated = 2 * _needed; \
+ Tcl_Token *oldPtr = (tokenPtr); \
+ Tcl_Token *newPtr; \
+ if (oldPtr == (staticPtr)) { \
+ oldPtr = NULL; \
+ } \
+ if (allocated > TCL_MAX_TOKENS) { \
+ allocated = TCL_MAX_TOKENS; \
+ } \
+ newPtr = (Tcl_Token *) attemptckrealloc((char *) oldPtr, \
+ (unsigned int) (allocated * sizeof(Tcl_Token))); \
+ if (newPtr == NULL) { \
+ allocated = _needed + (append) + TCL_MIN_TOKEN_GROWTH; \
+ if (allocated > TCL_MAX_TOKENS) { \
+ allocated = TCL_MAX_TOKENS; \
+ } \
+ newPtr = (Tcl_Token *) ckrealloc((char *) oldPtr, \
+ (unsigned int) (allocated * sizeof(Tcl_Token))); \
+ } \
+ (available) = allocated; \
+ if (oldPtr == NULL) { \
+ memcpy(newPtr, staticPtr, \
+ (size_t) ((used) * sizeof(Tcl_Token))); \
+ } \
+ (tokenPtr) = newPtr; \
+ } \
+ } while (0)
+
+#define TclGrowParseTokenArray(parsePtr, append) \
+ TclGrowTokenArray((parsePtr)->tokenPtr, (parsePtr)->numTokens, \
+ (parsePtr)->tokensAvailable, (append), \
+ (parsePtr)->staticTokens)
+
+/*
+ *----------------------------------------------------------------
+ * Macro used by the Tcl core get a unicode char from a utf string. It checks
+ * to see if we have a one-byte utf char before calling the real
+ * Tcl_UtfToUniChar, as this will save a lot of time for primarily ASCII
+ * string handling. The macro's expression result is 1 for the 1-byte case or
+ * the result of Tcl_UtfToUniChar. The ANSI C "prototype" for this macro is:
+ *
+ * MODULE_SCOPE int TclUtfToUniChar(const char *string, Tcl_UniChar *ch);
+ *----------------------------------------------------------------
+ */
+
+#define TclUtfToUniChar(str, chPtr) \
+ ((((unsigned char) *(str)) < 0xC0) ? \
+ ((*(chPtr) = (unsigned char) *(str)), 1) \
+ : Tcl_UtfToUniChar(str, chPtr))
+
+/*
+ *----------------------------------------------------------------
+ * Macro counterpart of the Tcl_NumUtfChars() function. To be used in speed-
+ * -sensitive points where it pays to avoid a function call in the common case
+ * of counting along a string of all one-byte characters. The ANSI C
+ * "prototype" for this macro is:
+ *
+ * MODULE_SCOPE void TclNumUtfChars(int numChars, const char *bytes,
+ * int numBytes);
+ *----------------------------------------------------------------
+ */
+
+#define TclNumUtfChars(numChars, bytes, numBytes) \
+ do { \
+ int _count, _i = (numBytes); \
+ unsigned char *_str = (unsigned char *) (bytes); \
+ while (_i && (*_str < 0xC0)) { _i--; _str++; } \
+ _count = (numBytes) - _i; \
+ if (_i) { \
+ _count += Tcl_NumUtfChars((bytes) + _count, _i); \
+ } \
+ (numChars) = _count; \
+ } while (0);
+
+/*
+ *----------------------------------------------------------------
+ * Macro that encapsulates the logic that determines when it is safe to
+ * interpret a string as a byte array directly. In summary, the object must be
+ * a byte array and must not have a string representation (as the operations
+ * that it is used in are defined on strings, not byte arrays). Theoretically
+ * it is possible to also be efficient in the case where the object's bytes
+ * field is filled by generation from the byte array (c.f. list canonicality)
+ * but we don't do that at the moment since this is purely about efficiency.
+ * The ANSI C "prototype" for this macro is:
+ *
+ * MODULE_SCOPE int TclIsPureByteArray(Tcl_Obj *objPtr);
+ *----------------------------------------------------------------
+ */
+
+#define TclIsPureByteArray(objPtr) \
+ (((objPtr)->typePtr==&tclByteArrayType) && ((objPtr)->bytes==NULL))
+
+/*
+ *----------------------------------------------------------------
+ * Macro used by the Tcl core to compare Unicode strings. On big-endian
+ * systems we can use the more efficient memcmp, but this would not be
+ * lexically correct on little-endian systems. The ANSI C "prototype" for
+ * this macro is:
+ *
+ * MODULE_SCOPE int TclUniCharNcmp(const Tcl_UniChar *cs,
+ * const Tcl_UniChar *ct, unsigned long n);
+ *----------------------------------------------------------------
+ */
+
+#ifdef WORDS_BIGENDIAN
+# define TclUniCharNcmp(cs,ct,n) memcmp((cs),(ct),(n)*sizeof(Tcl_UniChar))
+#else /* !WORDS_BIGENDIAN */
+# define TclUniCharNcmp Tcl_UniCharNcmp
+#endif /* WORDS_BIGENDIAN */
+
+/*
+ *----------------------------------------------------------------
+ * Macro used by the Tcl core to increment a namespace's export epoch
+ * counter. The ANSI C "prototype" for this macro is:
+ *
+ * MODULE_SCOPE void TclInvalidateNsCmdLookup(Namespace *nsPtr);
+ *----------------------------------------------------------------
+ */
+
+#define TclInvalidateNsCmdLookup(nsPtr) \
+ if ((nsPtr)->numExportPatterns) { \
+ (nsPtr)->exportLookupEpoch++; \
+ } \
+ if ((nsPtr)->commandPathLength) { \
+ (nsPtr)->cmdRefEpoch++; \
+ }
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Core procedure added to libtommath for bignum manipulation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+MODULE_SCOPE Tcl_PackageInitProc TclTommath_Init;
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * External (platform specific) initialization routine, these declarations
+ * explicitly don't use EXTERN since this code does not get compiled into the
+ * library:
+ *
+ *----------------------------------------------------------------------
+ */
+
+MODULE_SCOPE Tcl_PackageInitProc TclplatformtestInit;
+MODULE_SCOPE Tcl_PackageInitProc TclObjTest_Init;
+MODULE_SCOPE Tcl_PackageInitProc TclThread_Init;
+MODULE_SCOPE Tcl_PackageInitProc Procbodytest_Init;
+MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
+
+/*
+ *----------------------------------------------------------------
+ * Macro used by the Tcl core to check whether a pattern has any characters
+ * special to [string match]. The ANSI C "prototype" for this macro is:
+ *
+ * MODULE_SCOPE int TclMatchIsTrivial(const char *pattern);
+ *----------------------------------------------------------------
+ */
+
+#define TclMatchIsTrivial(pattern) \
+ (strpbrk((pattern), "*[?\\") == NULL)
+
+/*
+ *----------------------------------------------------------------
+ * Macros used by the Tcl core to set a Tcl_Obj's numeric representation
+ * avoiding the corresponding function calls in time critical parts of the
+ * core. They should only be called on unshared objects. The ANSI C
+ * "prototypes" for these macros are:
+ *
+ * MODULE_SCOPE void TclSetIntObj(Tcl_Obj *objPtr, int intValue);
+ * MODULE_SCOPE void TclSetLongObj(Tcl_Obj *objPtr, long longValue);
+ * MODULE_SCOPE void TclSetBooleanObj(Tcl_Obj *objPtr, long boolValue);
+ * MODULE_SCOPE void TclSetWideIntObj(Tcl_Obj *objPtr, Tcl_WideInt w);
+ * MODULE_SCOPE void TclSetDoubleObj(Tcl_Obj *objPtr, double d);
+ *----------------------------------------------------------------
+ */
+
+#define TclSetLongObj(objPtr, i) \
+ do { \
+ TclInvalidateStringRep(objPtr); \
+ TclFreeIntRep(objPtr); \
+ (objPtr)->internalRep.longValue = (long)(i); \
+ (objPtr)->typePtr = &tclIntType; \
+ } while (0)
+
+#define TclSetIntObj(objPtr, l) \
+ TclSetLongObj(objPtr, l)
+
+/*
+ * NOTE: There is to be no such thing as a "pure" boolean. Boolean values set
+ * programmatically go straight to being "int" Tcl_Obj's, with value 0 or 1.
+ * The only "boolean" Tcl_Obj's shall be those holding the cached boolean
+ * value of strings like: "yes", "no", "true", "false", "on", "off".
+ */
+
+#define TclSetBooleanObj(objPtr, b) \
+ TclSetLongObj(objPtr, (b)!=0);
+
+#ifndef TCL_WIDE_INT_IS_LONG
+#define TclSetWideIntObj(objPtr, w) \
+ do { \
+ TclInvalidateStringRep(objPtr); \
+ TclFreeIntRep(objPtr); \
+ (objPtr)->internalRep.wideValue = (Tcl_WideInt)(w); \
+ (objPtr)->typePtr = &tclWideIntType; \
+ } while (0)
+#endif
+
+#define TclSetDoubleObj(objPtr, d) \
+ do { \
+ TclInvalidateStringRep(objPtr); \
+ TclFreeIntRep(objPtr); \
+ (objPtr)->internalRep.doubleValue = (double)(d); \
+ (objPtr)->typePtr = &tclDoubleType; \
+ } while (0)
+
+/*
+ *----------------------------------------------------------------
+ * Macros used by the Tcl core to create and initialise objects of standard
+ * types, avoiding the corresponding function calls in time critical parts of
+ * the core. The ANSI C "prototypes" for these macros are:
+ *
+ * MODULE_SCOPE void TclNewIntObj(Tcl_Obj *objPtr, int i);
+ * MODULE_SCOPE void TclNewLongObj(Tcl_Obj *objPtr, long l);
+ * MODULE_SCOPE void TclNewBooleanObj(Tcl_Obj *objPtr, int b);
+ * MODULE_SCOPE void TclNewWideObj(Tcl_Obj *objPtr, Tcl_WideInt w);
+ * MODULE_SCOPE void TclNewDoubleObj(Tcl_Obj *objPtr, double d);
+ * MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, char *s, int len);
+ * MODULE_SCOPE void TclNewLiteralStringObj(Tcl_Obj*objPtr, char*sLiteral);
+ *
+ *----------------------------------------------------------------
+ */
+
+#ifndef TCL_MEM_DEBUG
+#define TclNewLongObj(objPtr, i) \
+ do { \
+ TclIncrObjsAllocated(); \
+ TclAllocObjStorage(objPtr); \
+ (objPtr)->refCount = 0; \
+ (objPtr)->bytes = NULL; \
+ (objPtr)->internalRep.longValue = (long)(i); \
+ (objPtr)->typePtr = &tclIntType; \
+ TCL_DTRACE_OBJ_CREATE(objPtr); \
+ } while (0)
+
+#define TclNewIntObj(objPtr, l) \
+ TclNewLongObj(objPtr, l)
+
+/*
+ * NOTE: There is to be no such thing as a "pure" boolean.
+ * See comment above TclSetBooleanObj macro above.
+ */
+#define TclNewBooleanObj(objPtr, b) \
+ TclNewLongObj((objPtr), (b)!=0)
+
+#define TclNewDoubleObj(objPtr, d) \
+ do { \
+ TclIncrObjsAllocated(); \
+ TclAllocObjStorage(objPtr); \
+ (objPtr)->refCount = 0; \
+ (objPtr)->bytes = NULL; \
+ (objPtr)->internalRep.doubleValue = (double)(d); \
+ (objPtr)->typePtr = &tclDoubleType; \
+ TCL_DTRACE_OBJ_CREATE(objPtr); \
+ } while (0)
+
+#define TclNewStringObj(objPtr, s, len) \
+ do { \
+ TclIncrObjsAllocated(); \
+ TclAllocObjStorage(objPtr); \
+ (objPtr)->refCount = 0; \
+ TclInitStringRep((objPtr), (s), (len)); \
+ (objPtr)->typePtr = NULL; \
+ TCL_DTRACE_OBJ_CREATE(objPtr); \
+ } while (0)
+
+#else /* TCL_MEM_DEBUG */
+#define TclNewIntObj(objPtr, i) \
+ (objPtr) = Tcl_NewIntObj(i)
+
+#define TclNewLongObj(objPtr, l) \
+ (objPtr) = Tcl_NewLongObj(l)
+
+#define TclNewBooleanObj(objPtr, b) \
+ (objPtr) = Tcl_NewBooleanObj(b)
+
+#define TclNewDoubleObj(objPtr, d) \
+ (objPtr) = Tcl_NewDoubleObj(d)
+
+#define TclNewStringObj(objPtr, s, len) \
+ (objPtr) = Tcl_NewStringObj((s), (len))
+#endif /* TCL_MEM_DEBUG */
+
+/*
+ * The sLiteral argument *must* be a string literal; the incantation with
+ * sizeof(sLiteral "") will fail to compile otherwise.
+ */
+#define TclNewLiteralStringObj(objPtr, sLiteral) \
+ TclNewStringObj((objPtr), (sLiteral), (int) (sizeof(sLiteral "") - 1))
+
+/*
+ *----------------------------------------------------------------
+ * Convenience macros for DStrings.
+ * The ANSI C "prototypes" for these macros are:
+ *
+ * MODULE_SCOPE char * TclDStringAppendLiteral(Tcl_DString *dsPtr,
+ * const char *sLiteral);
+ * MODULE_SCOPE void TclDStringClear(Tcl_DString *dsPtr);
+ */
+
+#define TclDStringAppendLiteral(dsPtr, sLiteral) \
+ Tcl_DStringAppend((dsPtr), (sLiteral), (int) (sizeof(sLiteral "") - 1))
+#define TclDStringClear(dsPtr) \
+ Tcl_DStringSetLength((dsPtr), 0)
+
+/*
+ *----------------------------------------------------------------
+ * Macros used by the Tcl core to test for some special double values.
+ * The ANSI C "prototypes" for these macros are:
+ *
+ * MODULE_SCOPE int TclIsInfinite(double d);
+ * MODULE_SCOPE int TclIsNaN(double d);
+ */
+
+#ifdef _MSC_VER
+# define TclIsInfinite(d) (!(_finite((d))))
+# define TclIsNaN(d) (_isnan((d)))
+#else
+# define TclIsInfinite(d) ((d) > DBL_MAX || (d) < -DBL_MAX)
+# ifdef NO_ISNAN
+# define TclIsNaN(d) ((d) != (d))
+# else
+# define TclIsNaN(d) (isnan(d))
+# endif
+#endif
+
+/*
+ * ----------------------------------------------------------------------
+ * Macro to use to find the offset of a field in a structure. Computes number
+ * of bytes from beginning of structure to a given field.
+ */
+
+#ifdef offsetof
+#define TclOffset(type, field) ((int) offsetof(type, field))
+#else
+#define TclOffset(type, field) ((int) ((char *) &((type *) 0)->field))
+#endif
+
+/*
+ *----------------------------------------------------------------
+ * Inline version of Tcl_GetCurrentNamespace and Tcl_GetGlobalNamespace.
+ */
+
+#define TclGetCurrentNamespace(interp) \
+ (Tcl_Namespace *) ((Interp *)(interp))->varFramePtr->nsPtr
+
+#define TclGetGlobalNamespace(interp) \
+ (Tcl_Namespace *) ((Interp *)(interp))->globalNsPtr
+
+/*
+ *----------------------------------------------------------------
+ * Inline version of TclCleanupCommand; still need the function as it is in
+ * the internal stubs, but the core can use the macro instead.
+ */
+
+#define TclCleanupCommandMacro(cmdPtr) \
+ if ((cmdPtr)->refCount-- <= 1) { \
+ ckfree((char *) (cmdPtr));\
+ }
+
+/*
+ *----------------------------------------------------------------
+ * Inline versions of Tcl_LimitReady() and Tcl_LimitExceeded to limit number
+ * of calls out of the critical path. Note that this code isn't particularly
+ * readable; the non-inline version (in tclInterp.c) is much easier to
+ * understand. Note also that these macros takes different args (iPtr->limit)
+ * to the non-inline version.
+ */
+
+#define TclLimitExceeded(limit) ((limit).exceeded != 0)
+
+#define TclLimitReady(limit) \
+ (((limit).active == 0) ? 0 : \
+ (++(limit).granularityTicker, \
+ ((((limit).active & TCL_LIMIT_COMMANDS) && \
+ (((limit).cmdGranularity == 1) || \
+ ((limit).granularityTicker % (limit).cmdGranularity == 0))) \
+ ? 1 : \
+ (((limit).active & TCL_LIMIT_TIME) && \
+ (((limit).timeGranularity == 1) || \
+ ((limit).granularityTicker % (limit).timeGranularity == 0)))\
+ ? 1 : 0)))
+
+/*
+ * Compile-time assertions: these produce a compile time error if the
+ * expression is not known to be true at compile time. If the assertion is
+ * known to be false, the compiler (or optimizer?) will error out with
+ * "division by zero". If the assertion cannot be evaluated at compile time,
+ * the compiler will error out with "non-static initializer".
+ *
+ * Adapted with permission from
+ * http://www.pixelbeat.org/programming/gcc/static_assert.html
+ */
+
+#define TCL_CT_ASSERT(e) \
+ {enum { ct_assert_value = 1/(!!(e)) };}
+
+/*
+ *----------------------------------------------------------------
+ * Allocator for small structs (<=sizeof(Tcl_Obj)) using the Tcl_Obj pool.
+ * Only checked at compile time.
+ *
+ * ONLY USE FOR CONSTANT nBytes.
+ *
+ * DO NOT LET THEM CROSS THREAD BOUNDARIES
+ *----------------------------------------------------------------
+ */
+
+#define TclSmallAlloc(nbytes, memPtr) \
+ TclSmallAllocEx(NULL, (nbytes), (memPtr))
+
+#define TclSmallFree(memPtr) \
+ TclSmallFreeEx(NULL, (memPtr))
+
+#ifndef TCL_MEM_DEBUG
+#define TclSmallAllocEx(interp, nbytes, memPtr) \
+ do { \
+ Tcl_Obj *_objPtr; \
+ TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj)); \
+ TclIncrObjsAllocated(); \
+ TclAllocObjStorageEx((interp), (_objPtr)); \
+ memPtr = (ClientData) (_objPtr); \
+ } while (0)
+
+#define TclSmallFreeEx(interp, memPtr) \
+ do { \
+ TclFreeObjStorageEx((interp), (Tcl_Obj *) (memPtr)); \
+ TclIncrObjsFreed(); \
+ } while (0)
+
+#else /* TCL_MEM_DEBUG */
+#define TclSmallAllocEx(interp, nbytes, memPtr) \
+ do { \
+ Tcl_Obj *_objPtr; \
+ TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj)); \
+ TclNewObj(_objPtr); \
+ memPtr = (ClientData) _objPtr; \
+ } while (0)
+
+#define TclSmallFreeEx(interp, memPtr) \
+ do { \
+ Tcl_Obj *_objPtr = (Tcl_Obj *) memPtr; \
+ _objPtr->bytes = NULL; \
+ _objPtr->typePtr = NULL; \
+ _objPtr->refCount = 1; \
+ TclDecrRefCount(_objPtr); \
+ } while (0)
+#endif /* TCL_MEM_DEBUG */
+
+/*
+ * Support for Clang Static Analyzer <http://clang-analyzer.llvm.org>
+ */
+
+#if defined(PURIFY) && defined(__clang__)
+#if __has_feature(attribute_analyzer_noreturn) && \
+ !defined(Tcl_Panic) && defined(Tcl_Panic_TCL_DECLARED)
+void Tcl_Panic(const char *, ...) __attribute__((analyzer_noreturn));
+#endif
+#if !defined(CLANG_ASSERT)
+#include <assert.h>
+#define CLANG_ASSERT(x) assert(x)
+#endif
+#elif !defined(CLANG_ASSERT)
+#define CLANG_ASSERT(x)
+#endif /* PURIFY && __clang__ */
+
+/*
+ *----------------------------------------------------------------
+ * Parameters, structs and macros for the non-recursive engine (NRE)
+ *----------------------------------------------------------------
+ */
+
+#define NRE_USE_SMALL_ALLOC 1 /* Only turn off for debugging purposes. */
+#ifndef NRE_ENABLE_ASSERTS
+#define NRE_ENABLE_ASSERTS 0
+#endif
+
+/*
+ * This is the main data struct for representing NR commands. It is designed
+ * to fit in sizeof(Tcl_Obj) in order to exploit the fastest memory allocator
+ * available.
+ */
+
+typedef struct NRE_callback {
+ Tcl_NRPostProc *procPtr;
+ ClientData data[4];
+ struct NRE_callback *nextPtr;
+} NRE_callback;
+
+#define TOP_CB(iPtr) (((Interp *)(iPtr))->execEnvPtr->callbackPtr)
+
+/*
+ * Inline version of Tcl_NRAddCallback.
+ */
+
+#define TclNRAddCallback(interp,postProcPtr,data0,data1,data2,data3) \
+ do { \
+ NRE_callback *_callbackPtr; \
+ TCLNR_ALLOC((interp), (_callbackPtr)); \
+ _callbackPtr->procPtr = (postProcPtr); \
+ _callbackPtr->data[0] = (ClientData)(data0); \
+ _callbackPtr->data[1] = (ClientData)(data1); \
+ _callbackPtr->data[2] = (ClientData)(data2); \
+ _callbackPtr->data[3] = (ClientData)(data3); \
+ _callbackPtr->nextPtr = TOP_CB(interp); \
+ TOP_CB(interp) = _callbackPtr; \
+ } while (0)
+
+#if NRE_USE_SMALL_ALLOC
+#define TCLNR_ALLOC(interp, ptr) \
+ TclSmallAllocEx(interp, sizeof(NRE_callback), (ptr))
+#define TCLNR_FREE(interp, ptr) TclSmallFreeEx((interp), (ptr))
+#else
+#define TCLNR_ALLOC(interp, ptr) \
+ (ptr = ((ClientData) ckalloc(sizeof(NRE_callback))))
+#define TCLNR_FREE(interp, ptr) ckfree((char *) (ptr))
+#endif
+
+#if NRE_ENABLE_ASSERTS
+#define NRE_ASSERT(expr) assert((expr))
+#else
+#define NRE_ASSERT(expr)
+#endif
+
+#include "tclIntDecls.h"
+#include "tclIntPlatDecls.h"
+#include "tclTomMathDecls.h"
+
+#if !defined(USE_TCL_STUBS) && !defined(TCL_MEM_DEBUG)
+#define Tcl_AttemptAlloc(size) TclpAlloc(size)
+#define Tcl_AttemptRealloc(ptr, size) TclpRealloc((ptr), (size))
+#define Tcl_Free(ptr) TclpFree(ptr)
+#endif
+
+#endif /* _TCLINT */
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclOO.c b/generic/tclOO.c
new file mode 100644
index 0000000..a27f92c
--- /dev/null
+++ b/generic/tclOO.c
@@ -0,0 +1,3073 @@
+/*
+ * tclOO.c --
+ *
+ * This file contains the object-system core (NB: not Tcl_Obj, but ::oo)
+ *
+ * Copyright (c) 2005-2012 by Donal K. Fellows
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ */
+
+#ifdef HAVE_CONFIG_H
+#include "config.h"
+#endif
+#include "tclInt.h"
+#include "tclOOInt.h"
+
+/*
+ * Commands in oo::define.
+ */
+
+static const struct {
+ const char *name;
+ Tcl_ObjCmdProc *objProc;
+ int flag;
+} defineCmds[] = {
+ {"constructor", TclOODefineConstructorObjCmd, 0},
+ {"deletemethod", TclOODefineDeleteMethodObjCmd, 0},
+ {"destructor", TclOODefineDestructorObjCmd, 0},
+ {"export", TclOODefineExportObjCmd, 0},
+ {"forward", TclOODefineForwardObjCmd, 0},
+ {"method", TclOODefineMethodObjCmd, 0},
+ {"renamemethod", TclOODefineRenameMethodObjCmd, 0},
+ {"self", TclOODefineSelfObjCmd, 0},
+ {"unexport", TclOODefineUnexportObjCmd, 0},
+ {NULL, NULL, 0}
+}, objdefCmds[] = {
+ {"class", TclOODefineClassObjCmd, 1},
+ {"deletemethod", TclOODefineDeleteMethodObjCmd, 1},
+ {"export", TclOODefineExportObjCmd, 1},
+ {"forward", TclOODefineForwardObjCmd, 1},
+ {"method", TclOODefineMethodObjCmd, 1},
+ {"renamemethod", TclOODefineRenameMethodObjCmd, 1},
+ {"unexport", TclOODefineUnexportObjCmd, 1},
+ {NULL, NULL, 0}
+};
+
+/*
+ * What sort of size of things we like to allocate.
+ */
+
+#define ALLOC_CHUNK 8
+
+/*
+ * Function declarations for things defined in this file.
+ */
+
+static Class * AllocClass(Tcl_Interp *interp, Object *useThisObj);
+static Object * AllocObject(Tcl_Interp *interp, const char *nameStr,
+ const char *nsNameStr);
+static void ClearMixins(Class *clsPtr);
+static void ClearSuperclasses(Class *clsPtr);
+static int CloneClassMethod(Tcl_Interp *interp, Class *clsPtr,
+ Method *mPtr, Tcl_Obj *namePtr,
+ Method **newMPtrPtr);
+static int CloneObjectMethod(Tcl_Interp *interp, Object *oPtr,
+ Method *mPtr, Tcl_Obj *namePtr);
+static void DeletedDefineNamespace(ClientData clientData);
+static void DeletedObjdefNamespace(ClientData clientData);
+static void DeletedHelpersNamespace(ClientData clientData);
+static Tcl_NRPostProc FinalizeAlloc;
+static Tcl_NRPostProc FinalizeNext;
+static Tcl_NRPostProc FinalizeObjectCall;
+static int InitFoundation(Tcl_Interp *interp);
+static void KillFoundation(ClientData clientData,
+ Tcl_Interp *interp);
+static void MyDeleted(ClientData clientData);
+static void ObjectNamespaceDeleted(ClientData clientData);
+static void ObjectRenamedTrace(ClientData clientData,
+ Tcl_Interp *interp, const char *oldName,
+ const char *newName, int flags);
+static void ReleaseClassContents(Tcl_Interp *interp,Object *oPtr);
+static inline void SquelchCachedName(Object *oPtr);
+static void SquelchedNsFirst(ClientData clientData);
+
+static int PublicObjectCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+static int PublicNRObjectCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+static int PrivateObjectCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+static int PrivateNRObjectCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+
+/*
+ * Methods in the oo::object and oo::class classes. First, we define a helper
+ * macro that makes building the method type declaration structure a lot
+ * easier. No point in making life harder than it has to be!
+ *
+ * Note that the core methods don't need clone or free proc callbacks.
+ */
+
+#define DCM(name,visibility,proc) \
+ {name,visibility,\
+ {TCL_OO_METHOD_VERSION_CURRENT,"core method: "#name,proc,NULL,NULL}}
+
+static const DeclaredClassMethod objMethods[] = {
+ DCM("destroy", 1, TclOO_Object_Destroy),
+ DCM("eval", 0, TclOO_Object_Eval),
+ DCM("unknown", 0, TclOO_Object_Unknown),
+ DCM("variable", 0, TclOO_Object_LinkVar),
+ DCM("varname", 0, TclOO_Object_VarName),
+ {NULL, 0, {0, NULL, NULL, NULL, NULL}}
+}, clsMethods[] = {
+ DCM("create", 1, TclOO_Class_Create),
+ DCM("new", 1, TclOO_Class_New),
+ DCM("createWithNamespace", 0, TclOO_Class_CreateNs),
+ {NULL, 0, {0, NULL, NULL, NULL, NULL}}
+};
+
+/*
+ * And for the oo::class constructor...
+ */
+
+static const Tcl_MethodType classConstructor = {
+ TCL_OO_METHOD_VERSION_CURRENT,
+ "oo::class constructor",
+ TclOO_Class_Constructor, NULL, NULL
+};
+
+/*
+ * Scripted parts of TclOO. First, the master script (cannot be outside this
+ * file).
+ */
+
+static const char *initScript =
+"package ifneeded TclOO " TCLOO_PATCHLEVEL " {# Already present, OK?};"
+"namespace eval ::oo { variable version " TCLOO_VERSION " };"
+"namespace eval ::oo { variable patchlevel " TCLOO_PATCHLEVEL " };";
+/* "tcl_findLibrary tcloo $oo::version $oo::version" */
+/* " tcloo.tcl OO_LIBRARY oo::library;"; */
+
+/*
+ * The scripted part of the definitions of slots.
+ */
+
+static const char *slotScript =
+"::oo::define ::oo::Slot {\n"
+" method Get {} {error unimplemented}\n"
+" method Set list {error unimplemented}\n"
+" method -set args {\n"
+" uplevel 1 [list [namespace which my] Set $args]\n"
+" }\n"
+" method -append args {\n"
+" uplevel 1 [list [namespace which my] Set [list"
+" {*}[uplevel 1 [list [namespace which my] Get]] {*}$args]]\n"
+" }\n"
+" method -clear {} {uplevel 1 [list [namespace which my] Set {}]}\n"
+" forward --default-operation my -append\n"
+" method unknown {args} {\n"
+" set def --default-operation\n"
+" if {[llength $args] == 0} {\n"
+" return [uplevel 1 [list [namespace which my] $def]]\n"
+" } elseif {![string match -* [lindex $args 0]]} {\n"
+" return [uplevel 1 [list [namespace which my] $def {*}$args]]\n"
+" }\n"
+" next {*}$args\n"
+" }\n"
+" export -set -append -clear\n"
+" unexport unknown destroy\n"
+"}\n"
+"::oo::objdefine ::oo::define::superclass forward --default-operation my -set\n"
+"::oo::objdefine ::oo::define::mixin forward --default-operation my -set\n"
+"::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set\n";
+
+/*
+ * The body of the <cloned> method of oo::object.
+ */
+
+static const char *clonedBody =
+"foreach p [info procs [info object namespace $originObject]::*] {"
+" set args [info args $p];"
+" set idx -1;"
+" foreach a $args {"
+" lset args [incr idx] "
+" [if {[info default $p $a d]} {list $a $d} {list $a}]"
+" };"
+" set b [info body $p];"
+" set p [namespace tail $p];"
+" proc $p $args $b;"
+"};"
+"foreach v [info vars [info object namespace $originObject]::*] {"
+" upvar 0 $v vOrigin;"
+" namespace upvar [namespace current] [namespace tail $v] vNew;"
+" if {[info exists vOrigin]} {"
+" if {[array exists vOrigin]} {"
+" array set vNew [array get vOrigin];"
+" } else {"
+" set vNew $vOrigin;"
+" }"
+" }"
+"}";
+
+/*
+ * The actual definition of the variable holding the TclOO stub table.
+ */
+
+MODULE_SCOPE const TclOOStubs tclOOStubs;
+
+/*
+ * Convenience macro for getting the foundation from an interpreter.
+ */
+
+#define GetFoundation(interp) \
+ ((Foundation *)((Interp *)(interp))->objectFoundation)
+
+/*
+ * Macros to make inspecting into the guts of an object cleaner.
+ *
+ * The ocPtr parameter (only in these macros) is assumed to work fine with
+ * either an oPtr or a classPtr. Note that the roots oo::object and oo::class
+ * have _both_ their object and class flags tagged with ROOT_OBJECT and
+ * ROOT_CLASS respectively.
+ */
+
+#define Deleted(oPtr) (((Object *)(oPtr))->command == NULL)
+#define IsRootObject(ocPtr) ((ocPtr)->flags & ROOT_OBJECT)
+#define IsRootClass(ocPtr) ((ocPtr)->flags & ROOT_CLASS)
+#define IsRoot(ocPtr) ((ocPtr)->flags & (ROOT_OBJECT|ROOT_CLASS))
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOInit --
+ *
+ * Called to initialise the OO system within an interpreter.
+ *
+ * Result:
+ * TCL_OK if the setup succeeded. Currently assumed to always work.
+ *
+ * Side effects:
+ * Creates namespaces, commands, several classes and a number of
+ * callbacks. Upon return, the OO system is ready for use.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOOInit(
+ Tcl_Interp *interp) /* The interpreter to install into. */
+{
+ /*
+ * Build the core of the OO system.
+ */
+
+ if (InitFoundation(interp) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Run our initialization script and, if that works, declare the package
+ * to be fully provided.
+ */
+
+ if (Tcl_Eval(interp, initScript) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ return Tcl_PkgProvideEx(interp, "TclOO", TCLOO_PATCHLEVEL,
+ (ClientData) &tclOOStubs);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOGetFoundation --
+ *
+ * Get a reference to the OO core class system.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Foundation *
+TclOOGetFoundation(
+ Tcl_Interp *interp)
+{
+ return GetFoundation(interp);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InitFoundation --
+ *
+ * Set up the core of the OO core class system. This is a structure
+ * holding references to the magical bits that need to be known about in
+ * other places, plus the oo::object and oo::class classes.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InitFoundation(
+ Tcl_Interp *interp)
+{
+ static Tcl_ThreadDataKey tsdKey;
+ ThreadLocalData *tsdPtr =
+ Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData));
+ Foundation *fPtr = ckalloc(sizeof(Foundation));
+ Tcl_Obj *namePtr, *argsPtr, *bodyPtr;
+ Tcl_DString buffer;
+ Command *cmdPtr;
+ int i;
+
+ /*
+ * Initialize the structure that holds the OO system core. This is
+ * attached to the interpreter via an assocData entry; not very efficient,
+ * but the best we can do without hacking the core more.
+ */
+
+ memset(fPtr, 0, sizeof(Foundation));
+ ((Interp *) interp)->objectFoundation = fPtr;
+ fPtr->interp = interp;
+ fPtr->ooNs = Tcl_CreateNamespace(interp, "::oo", fPtr, NULL);
+ Tcl_Export(interp, fPtr->ooNs, "[a-z]*", 1);
+ fPtr->defineNs = Tcl_CreateNamespace(interp, "::oo::define", fPtr,
+ DeletedDefineNamespace);
+ fPtr->objdefNs = Tcl_CreateNamespace(interp, "::oo::objdefine", fPtr,
+ DeletedObjdefNamespace);
+ fPtr->helpersNs = Tcl_CreateNamespace(interp, "::oo::Helpers", fPtr,
+ DeletedHelpersNamespace);
+ fPtr->epoch = 0;
+ fPtr->tsdPtr = tsdPtr;
+ TclNewLiteralStringObj(fPtr->unknownMethodNameObj, "unknown");
+ TclNewLiteralStringObj(fPtr->constructorName, "<constructor>");
+ TclNewLiteralStringObj(fPtr->destructorName, "<destructor>");
+ TclNewLiteralStringObj(fPtr->clonedName, "<cloned>");
+ TclNewLiteralStringObj(fPtr->defineName, "::oo::define");
+ Tcl_IncrRefCount(fPtr->unknownMethodNameObj);
+ Tcl_IncrRefCount(fPtr->constructorName);
+ Tcl_IncrRefCount(fPtr->destructorName);
+ Tcl_IncrRefCount(fPtr->clonedName);
+ Tcl_IncrRefCount(fPtr->defineName);
+ Tcl_CreateObjCommand(interp, "::oo::UnknownDefinition",
+ TclOOUnknownDefinition, NULL, NULL);
+ TclNewLiteralStringObj(namePtr, "::oo::UnknownDefinition");
+ Tcl_SetNamespaceUnknownHandler(interp, fPtr->defineNs, namePtr);
+ Tcl_SetNamespaceUnknownHandler(interp, fPtr->objdefNs, namePtr);
+
+ /*
+ * Create the subcommands in the oo::define and oo::objdefine spaces.
+ */
+
+ Tcl_DStringInit(&buffer);
+ for (i=0 ; defineCmds[i].name ; i++) {
+ TclDStringAppendLiteral(&buffer, "::oo::define::");
+ Tcl_DStringAppend(&buffer, defineCmds[i].name, -1);
+ Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
+ defineCmds[i].objProc, INT2PTR(defineCmds[i].flag), NULL);
+ Tcl_DStringFree(&buffer);
+ }
+ for (i=0 ; objdefCmds[i].name ; i++) {
+ TclDStringAppendLiteral(&buffer, "::oo::objdefine::");
+ Tcl_DStringAppend(&buffer, objdefCmds[i].name, -1);
+ Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer),
+ objdefCmds[i].objProc, INT2PTR(objdefCmds[i].flag), NULL);
+ Tcl_DStringFree(&buffer);
+ }
+
+ Tcl_CallWhenDeleted(interp, KillFoundation, NULL);
+
+ /*
+ * Create the objects at the core of the object system. These need to be
+ * spliced manually.
+ */
+
+ fPtr->objectCls = AllocClass(interp,
+ AllocObject(interp, "::oo::object", NULL));
+ fPtr->classCls = AllocClass(interp,
+ AllocObject(interp, "::oo::class", NULL));
+ fPtr->objectCls->thisPtr->selfCls = fPtr->classCls;
+ fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT;
+ fPtr->objectCls->flags |= ROOT_OBJECT;
+ fPtr->objectCls->superclasses.num = 0;
+ ckfree(fPtr->objectCls->superclasses.list);
+ fPtr->objectCls->superclasses.list = NULL;
+ fPtr->classCls->thisPtr->selfCls = fPtr->classCls;
+ fPtr->classCls->thisPtr->flags |= ROOT_CLASS;
+ fPtr->classCls->flags |= ROOT_CLASS;
+ TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls);
+ TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls);
+ TclOOAddToSubclasses(fPtr->classCls, fPtr->objectCls);
+ AddRef(fPtr->objectCls->thisPtr);
+ AddRef(fPtr->objectCls);
+
+ /*
+ * Basic method declarations for the core classes.
+ */
+
+ for (i=0 ; objMethods[i].name ; i++) {
+ TclOONewBasicMethod(interp, fPtr->objectCls, &objMethods[i]);
+ }
+ for (i=0 ; clsMethods[i].name ; i++) {
+ TclOONewBasicMethod(interp, fPtr->classCls, &clsMethods[i]);
+ }
+
+ /*
+ * Create the default <cloned> method implementation, used when 'oo::copy'
+ * is called to finish the copying of one object to another.
+ */
+
+ TclNewLiteralStringObj(argsPtr, "originObject");
+ Tcl_IncrRefCount(argsPtr);
+ bodyPtr = Tcl_NewStringObj(clonedBody, -1);
+ TclOONewProcMethod(interp, fPtr->objectCls, 0, fPtr->clonedName, argsPtr,
+ bodyPtr, NULL);
+ TclDecrRefCount(argsPtr);
+
+ /*
+ * Finish setting up the class of classes by marking the 'new' method as
+ * private; classes, unlike general objects, must have explicit names. We
+ * also need to create the constructor for classes.
+ */
+
+ TclNewLiteralStringObj(namePtr, "new");
+ Tcl_NewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr,
+ namePtr /* keeps ref */, 0 /* ==private */, NULL, NULL);
+ fPtr->classCls->constructorPtr = (Method *) Tcl_NewMethod(interp,
+ (Tcl_Class) fPtr->classCls, NULL, 0, &classConstructor, NULL);
+
+ /*
+ * Create non-object commands and plug ourselves into the Tcl [info]
+ * ensemble.
+ */
+
+ cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::next",
+ NULL, TclOONextObjCmd, NULL, NULL);
+ cmdPtr->compileProc = TclCompileObjectNextCmd;
+ cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::nextto",
+ NULL, TclOONextToObjCmd, NULL, NULL);
+ cmdPtr->compileProc = TclCompileObjectNextToCmd;
+ cmdPtr = (Command *) Tcl_CreateObjCommand(interp, "::oo::Helpers::self",
+ TclOOSelfObjCmd, NULL, NULL);
+ cmdPtr->compileProc = TclCompileObjectSelfCmd;
+ Tcl_CreateObjCommand(interp, "::oo::define", TclOODefineObjCmd, NULL,
+ NULL);
+ Tcl_CreateObjCommand(interp, "::oo::objdefine", TclOOObjDefObjCmd, NULL,
+ NULL);
+ Tcl_CreateObjCommand(interp, "::oo::copy", TclOOCopyObjectCmd, NULL,NULL);
+ TclOOInitInfo(interp);
+
+ /*
+ * Now make the class of slots.
+ */
+
+ if (TclOODefineSlots(fPtr) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ return Tcl_Eval(interp, slotScript);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * DeletedDefineNamespace, DeletedObjdefNamespace, DeletedHelpersNamespace --
+ *
+ * Simple helpers used to clear fields of the foundation when they no
+ * longer hold useful information.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+DeletedDefineNamespace(
+ ClientData clientData)
+{
+ Foundation *fPtr = clientData;
+
+ fPtr->defineNs = NULL;
+}
+
+static void
+DeletedObjdefNamespace(
+ ClientData clientData)
+{
+ Foundation *fPtr = clientData;
+
+ fPtr->objdefNs = NULL;
+}
+
+static void
+DeletedHelpersNamespace(
+ ClientData clientData)
+{
+ Foundation *fPtr = clientData;
+
+ fPtr->helpersNs = NULL;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * KillFoundation --
+ *
+ * Delete those parts of the OO core that are not deleted automatically
+ * when the objects and classes themselves are destroyed.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+KillFoundation(
+ ClientData clientData, /* Pointer to the OO system foundation
+ * structure. */
+ Tcl_Interp *interp) /* The interpreter containing the OO system
+ * foundation. */
+{
+ Foundation *fPtr = GetFoundation(interp);
+
+ DelRef(fPtr->objectCls->thisPtr);
+ DelRef(fPtr->objectCls);
+ TclDecrRefCount(fPtr->unknownMethodNameObj);
+ TclDecrRefCount(fPtr->constructorName);
+ TclDecrRefCount(fPtr->destructorName);
+ TclDecrRefCount(fPtr->clonedName);
+ TclDecrRefCount(fPtr->defineName);
+ ckfree(fPtr);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AllocObject --
+ *
+ * Allocate an object of basic type. Does not splice the object into its
+ * class's instance list. The caller must set the classPtr on the object,
+ * either to a class or to NULL.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static Object *
+AllocObject(
+ Tcl_Interp *interp, /* Interpreter within which to create the
+ * object. */
+ const char *nameStr, /* The name of the object to create, or NULL
+ * if the OO system should pick the object
+ * name itself (equal to the namespace
+ * name). */
+ const char *nsNameStr) /* The name of the namespace to create, or
+ * NULL if the OO system should pick a unique
+ * name itself. If this is non-NULL but names
+ * a namespace that already exists, the effect
+ * will be the same as if this was NULL. */
+{
+ Foundation *fPtr = GetFoundation(interp);
+ Object *oPtr;
+ Command *cmdPtr;
+ CommandTrace *tracePtr;
+ Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
+ Tcl_Namespace *inNsPtr;
+ int creationEpoch, ignored;
+ const char *simpleName;
+
+ oPtr = ckalloc(sizeof(Object));
+ memset(oPtr, 0, sizeof(Object));
+
+ /*
+ * Every object has a namespace; make one. Note that this also normally
+ * computes the creation epoch value for the object, a sequence number
+ * that is unique to the object (and which allows us to manage method
+ * caching without comparing pointers).
+ *
+ * When creating a namespace, we first check to see if the caller
+ * specified the name for the namespace. If not, we generate namespace
+ * names using the epoch until such time as a new namespace is actually
+ * created.
+ */
+
+ if (nsNameStr != NULL) {
+ oPtr->namespacePtr = Tcl_CreateNamespace(interp, nsNameStr, oPtr,
+ ObjectNamespaceDeleted);
+ if (oPtr->namespacePtr != NULL) {
+ creationEpoch = ++fPtr->tsdPtr->nsCount;
+ goto configNamespace;
+ }
+ Tcl_ResetResult(interp);
+ }
+
+ while (1) {
+ char objName[10 + TCL_INTEGER_SPACE];
+
+ sprintf(objName, "::oo::Obj%d", ++fPtr->tsdPtr->nsCount);
+ oPtr->namespacePtr = Tcl_CreateNamespace(interp, objName, oPtr,
+ ObjectNamespaceDeleted);
+ if (oPtr->namespacePtr != NULL) {
+ creationEpoch = fPtr->tsdPtr->nsCount;
+ break;
+ }
+
+ /*
+ * Could not make that namespace, so we make another. But first we
+ * have to get rid of the error message from Tcl_CreateNamespace,
+ * since that's something that should not be exposed to the user.
+ */
+
+ Tcl_ResetResult(interp);
+ }
+
+ /*
+ * Make the namespace know about the helper commands. This grants access
+ * to the [self] and [next] commands.
+ */
+
+ configNamespace:
+ if (fPtr->helpersNs != NULL) {
+ TclSetNsPath((Namespace *) oPtr->namespacePtr, 1, &fPtr->helpersNs);
+ }
+ TclOOSetupVariableResolver(oPtr->namespacePtr);
+
+ /*
+ * Suppress use of compiled versions of the commands in this object's
+ * namespace and its children; causes wrong behaviour without expensive
+ * recompilation. [Bug 2037727]
+ */
+
+ ((Namespace *) oPtr->namespacePtr)->flags |= NS_SUPPRESS_COMPILATION;
+
+ /*
+ * Set up a callback to get notification of the deletion of a namespace
+ * when enough of the namespace still remains to execute commands and
+ * access variables in it. [Bug 2950259]
+ */
+
+ ((Namespace *) oPtr->namespacePtr)->earlyDeleteProc = SquelchedNsFirst;
+
+ /*
+ * Fill in the rest of the non-zero/NULL parts of the structure.
+ */
+
+ oPtr->fPtr = fPtr;
+ oPtr->selfCls = fPtr->objectCls;
+ oPtr->creationEpoch = creationEpoch;
+ oPtr->refCount = 1;
+ oPtr->flags = USE_CLASS_CACHE;
+
+ /*
+ * Finally, create the object commands and initialize the trace on the
+ * public command (so that the object structures are deleted when the
+ * command is deleted).
+ */
+
+ if (nameStr) {
+ inNsPtr = TclGetCurrentNamespace(interp);
+ } else {
+ nameStr = oPtr->namespacePtr->name;
+ inNsPtr = oPtr->namespacePtr;
+ }
+
+ TclGetNamespaceForQualName(interp, nameStr, (Namespace *) inNsPtr, 0,
+ &nsPtr, &altNsPtr, &cxtNsPtr, &simpleName);
+
+ oPtr->command = TclCreateObjCommandInNs(interp, simpleName,
+ (Tcl_Namespace *)nsPtr, PublicObjectCmd, oPtr, NULL);
+
+ /*
+ * Add the NRE command and trace directly. While this breaks a number of
+ * abstractions, it is faster and we're inside Tcl here so we're allowed.
+ */
+
+ cmdPtr = (Command *) oPtr->command;
+ cmdPtr->nreProc = PublicNRObjectCmd;
+ cmdPtr->tracePtr = tracePtr = ckalloc(sizeof(CommandTrace));
+ tracePtr->traceProc = ObjectRenamedTrace;
+ tracePtr->clientData = oPtr;
+ tracePtr->flags = TCL_TRACE_RENAME|TCL_TRACE_DELETE;
+ tracePtr->nextPtr = NULL;
+ tracePtr->refCount = 1;
+
+ /*
+ * Access the namespace command table directly when creating "my" to avoid
+ * a bottleneck in string manipulation. Another abstraction-buster.
+ */
+
+ cmdPtr = ckalloc(sizeof(Command));
+ memset(cmdPtr, 0, sizeof(Command));
+ cmdPtr->nsPtr = (Namespace *) oPtr->namespacePtr;
+ cmdPtr->hPtr = Tcl_CreateHashEntry(&cmdPtr->nsPtr->cmdTable, "my",
+ &ignored);
+ cmdPtr->refCount = 1;
+ cmdPtr->objProc = PrivateObjectCmd;
+ cmdPtr->deleteProc = MyDeleted;
+ cmdPtr->objClientData = cmdPtr->deleteData = oPtr;
+ cmdPtr->proc = TclInvokeObjectCommand;
+ cmdPtr->clientData = cmdPtr;
+ cmdPtr->nreProc = PrivateNRObjectCmd;
+ Tcl_SetHashValue(cmdPtr->hPtr, cmdPtr);
+ oPtr->myCommand = (Tcl_Command) cmdPtr;
+
+ return oPtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * SquelchCachedName --
+ *
+ * Encapsulates how to throw away a cached object name. Called from
+ * object rename traces and at object destruction.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline void
+SquelchCachedName(
+ Object *oPtr)
+{
+ if (oPtr->cachedNameObj) {
+ Tcl_DecrRefCount(oPtr->cachedNameObj);
+ oPtr->cachedNameObj = NULL;
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * MyDeleted --
+ *
+ * This callback is triggered when the object's [my] command is deleted
+ * by any mechanism. It just marks the object as not having a [my]
+ * command, and so prevents cleanup of that when the object itself is
+ * deleted.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+MyDeleted(
+ ClientData clientData) /* Reference to the object whose [my] has been
+ * squelched. */
+{
+ register Object *oPtr = clientData;
+
+ oPtr->myCommand = NULL;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * SquelchedNsFirst --
+ *
+ * This callback is triggered when the object's namespace is deleted by
+ * any mechanism. It deletes the object's public command if it has not
+ * already been deleted, so ensuring that destructors get run at an
+ * appropriate time. [Bug 2950259]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+SquelchedNsFirst(
+ ClientData clientData)
+{
+ Object *oPtr = clientData;
+
+ if (oPtr->command) {
+ Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command);
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ObjectRenamedTrace --
+ *
+ * This callback is triggered when the object is deleted by any
+ * mechanism. It runs the destructors and arranges for the actual cleanup
+ * of the object's namespace, which in turn triggers cleansing of the
+ * object data structures.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+ObjectRenamedTrace(
+ ClientData clientData, /* The object being deleted. */
+ Tcl_Interp *interp, /* The interpreter containing the object. */
+ const char *oldName, /* What the object was (last) called. */
+ const char *newName, /* What it's getting renamed to. (unused) */
+ int flags) /* Why was the object deleted? */
+{
+ Object *oPtr = clientData;
+ Foundation *fPtr = oPtr->fPtr;
+
+ /*
+ * If this is a rename and not a delete of the object, we just flush the
+ * cache of the object name.
+ */
+
+ if (flags & TCL_TRACE_RENAME) {
+ SquelchCachedName(oPtr);
+ return;
+ }
+
+ /*
+ * Oh dear, the object really is being deleted. Handle this by running the
+ * destructors and deleting the object's namespace, which in turn causes
+ * the real object structures to be deleted.
+ *
+ * Note that it is possible for the namespace to be deleted before the
+ * command. Because of that case, we must take care here to mark the
+ * command as being deleted so that if we return here we don't run into
+ * reentrancy problems.
+ *
+ * We also do not run destructors on the core class objects when the
+ * interpreter is being deleted; their incestuous nature causes problems
+ * in that case when the destructor is partially deleted before the uses
+ * of it have gone. [Bug 2949397]
+ */
+
+ AddRef(oPtr);
+ AddRef(fPtr->classCls);
+ AddRef(fPtr->objectCls);
+ AddRef(fPtr->classCls->thisPtr);
+ AddRef(fPtr->objectCls->thisPtr);
+ oPtr->command = NULL;
+
+ if (!(oPtr->flags & DESTRUCTOR_CALLED) && !Tcl_InterpDeleted(interp)) {
+ CallContext *contextPtr =
+ TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL);
+ int result;
+ Tcl_InterpState state;
+
+ oPtr->flags |= DESTRUCTOR_CALLED;
+ if (contextPtr != NULL) {
+ contextPtr->callPtr->flags |= DESTRUCTOR;
+ contextPtr->skip = 0;
+ state = Tcl_SaveInterpState(interp, TCL_OK);
+ result = Tcl_NRCallObjProc(interp, TclOOInvokeContext,
+ contextPtr, 0, NULL);
+ if (result != TCL_OK) {
+ Tcl_BackgroundException(interp, result);
+ }
+ Tcl_RestoreInterpState(interp, state);
+ TclOODeleteContext(contextPtr);
+ }
+ }
+
+ /*
+ * OK, the destructor's been run. Time to splat the class data (if any)
+ * and nuke the namespace (which triggers the final crushing of the object
+ * structure itself).
+ *
+ * The class of objects needs some special care; if it is deleted (and
+ * we're not killing the whole interpreter) we force the delete of the
+ * class of classes now as well. Due to the incestuous nature of those two
+ * classes, if one goes the other must too and yet the tangle can
+ * sometimes not go away automatically; we force it here. [Bug 2962664]
+ */
+
+ if (!Tcl_InterpDeleted(interp) && IsRootObject(oPtr)
+ && !Deleted(fPtr->classCls->thisPtr)) {
+ Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command);
+ }
+
+ if (oPtr->classPtr != NULL) {
+ AddRef(oPtr->classPtr);
+ ReleaseClassContents(interp, oPtr);
+ }
+
+ /*
+ * The namespace is only deleted if it hasn't already been deleted. [Bug
+ * 2950259]
+ */
+
+ if (oPtr->namespacePtr && ((Namespace *) oPtr->namespacePtr)->earlyDeleteProc != NULL) {
+ Tcl_DeleteNamespace(oPtr->namespacePtr);
+ }
+ if (oPtr->classPtr) {
+ DelRef(oPtr->classPtr);
+ }
+ DelRef(fPtr->classCls->thisPtr);
+ DelRef(fPtr->objectCls->thisPtr);
+ DelRef(fPtr->classCls);
+ DelRef(fPtr->objectCls);
+ DelRef(oPtr);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ClearMixins, ClearSuperclasses --
+ *
+ * Utility functions for correctly clearing the list of mixins or
+ * superclasses of a class. Will ckfree() the list storage.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+ClearMixins(
+ Class *clsPtr)
+{
+ int i;
+ Class *mixinPtr;
+
+ if (clsPtr->mixins.num == 0) {
+ return;
+ }
+
+ FOREACH(mixinPtr, clsPtr->mixins) {
+ TclOORemoveFromMixinSubs(clsPtr, mixinPtr);
+ }
+ ckfree(clsPtr->mixins.list);
+ clsPtr->mixins.list = NULL;
+ clsPtr->mixins.num = 0;
+}
+
+static void
+ClearSuperclasses(
+ Class *clsPtr)
+{
+ int i;
+ Class *superPtr;
+
+ if (clsPtr->superclasses.num == 0) {
+ return;
+ }
+
+ FOREACH(superPtr, clsPtr->superclasses) {
+ TclOORemoveFromSubclasses(clsPtr, superPtr);
+ }
+ ckfree(clsPtr->superclasses.list);
+ clsPtr->superclasses.list = NULL;
+ clsPtr->superclasses.num = 0;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ReleaseClassContents --
+ *
+ * Tear down the special class data structure, including deleting all
+ * dependent classes and objects.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+ReleaseClassContents(
+ Tcl_Interp *interp, /* The interpreter containing the class. */
+ Object *oPtr) /* The object representing the class. */
+{
+ FOREACH_HASH_DECLS;
+ int i;
+ Class *clsPtr = oPtr->classPtr, *mixinSubclassPtr, *subclassPtr;
+ Object *instancePtr;
+ Foundation *fPtr = oPtr->fPtr;
+
+ /*
+ * Sanity check!
+ */
+
+ if (!Deleted(oPtr)) {
+ if (IsRootClass(oPtr)) {
+ Tcl_Panic("deleting class structure for non-deleted %s",
+ "::oo::class");
+ } else if (IsRootObject(oPtr)) {
+ Tcl_Panic("deleting class structure for non-deleted %s",
+ "::oo::object");
+ } else {
+ Tcl_Panic("deleting class structure for non-deleted %s",
+ "general object");
+ }
+ }
+
+ /*
+ * Lock a number of dependent objects until we've stopped putting our
+ * fingers in them.
+ */
+
+ FOREACH(mixinSubclassPtr, clsPtr->mixinSubs) {
+ if (mixinSubclassPtr != NULL) {
+ AddRef(mixinSubclassPtr);
+ AddRef(mixinSubclassPtr->thisPtr);
+ }
+ }
+ FOREACH(subclassPtr, clsPtr->subclasses) {
+ if (subclassPtr != NULL && !IsRoot(subclassPtr)) {
+ AddRef(subclassPtr);
+ AddRef(subclassPtr->thisPtr);
+ }
+ }
+ if (!IsRootClass(oPtr)) {
+ FOREACH(instancePtr, clsPtr->instances) {
+ int j;
+ if (instancePtr->selfCls == clsPtr) {
+ instancePtr->flags |= CLASS_GONE;
+ }
+ for(j=0 ; j<instancePtr->mixins.num ; j++) {
+ Class *mixin = instancePtr->mixins.list[j];
+ Class *nextMixin = NULL;
+ if (mixin == clsPtr) {
+ if (j < instancePtr->mixins.num - 1) {
+ nextMixin = instancePtr->mixins.list[j+1];
+ }
+ if (j == 0) {
+ instancePtr->mixins.num = 0;
+ instancePtr->mixins.list = NULL;
+ } else {
+ instancePtr->mixins.list[j-1] = nextMixin;
+ }
+ instancePtr->mixins.num -= 1;
+ }
+ }
+ if (instancePtr != NULL && !IsRoot(instancePtr)) {
+ AddRef(instancePtr);
+ }
+ }
+ }
+
+ /*
+ * Squelch classes that this class has been mixed into.
+ */
+
+ FOREACH(mixinSubclassPtr, clsPtr->mixinSubs) {
+ if (!Deleted(mixinSubclassPtr->thisPtr)) {
+ Tcl_DeleteCommandFromToken(interp,
+ mixinSubclassPtr->thisPtr->command);
+ }
+ ClearMixins(mixinSubclassPtr);
+ DelRef(mixinSubclassPtr->thisPtr);
+ DelRef(mixinSubclassPtr);
+ }
+ if (clsPtr->mixinSubs.list != NULL) {
+ ckfree(clsPtr->mixinSubs.list);
+ clsPtr->mixinSubs.list = NULL;
+ clsPtr->mixinSubs.num = 0;
+ }
+
+ /*
+ * Squelch subclasses of this class.
+ */
+
+ FOREACH(subclassPtr, clsPtr->subclasses) {
+ if (IsRoot(subclassPtr)) {
+ continue;
+ }
+ if (!Deleted(subclassPtr->thisPtr)) {
+ Tcl_DeleteCommandFromToken(interp, subclassPtr->thisPtr->command);
+ }
+ ClearSuperclasses(subclassPtr);
+ DelRef(subclassPtr->thisPtr);
+ DelRef(subclassPtr);
+ }
+ if (clsPtr->subclasses.list != NULL) {
+ ckfree(clsPtr->subclasses.list);
+ clsPtr->subclasses.list = NULL;
+ clsPtr->subclasses.num = 0;
+ }
+
+ /*
+ * Squelch instances of this class (includes objects we're mixed into).
+ */
+
+ if (!IsRootClass(oPtr)) {
+ FOREACH(instancePtr, clsPtr->instances) {
+ if (instancePtr == NULL || IsRoot(instancePtr)) {
+ continue;
+ }
+ if (!Deleted(instancePtr)) {
+ Tcl_DeleteCommandFromToken(interp, instancePtr->command);
+ /*
+ * Tcl_DeleteCommandFromToken() may have done to whole
+ * job for us. Roll back and check again.
+ */
+ i--;
+ continue;
+ }
+ DelRef(instancePtr);
+ }
+ }
+ if (clsPtr->instances.list != NULL) {
+ ckfree(clsPtr->instances.list);
+ clsPtr->instances.list = NULL;
+ clsPtr->instances.num = 0;
+ }
+
+ /*
+ * Special: We delete these after everything else.
+ */
+
+ if (IsRootClass(oPtr) && !Deleted(fPtr->objectCls->thisPtr)) {
+ Tcl_DeleteCommandFromToken(interp, fPtr->objectCls->thisPtr->command);
+ }
+
+ /*
+ * Squelch method implementation chain caches.
+ */
+
+ if (clsPtr->constructorChainPtr) {
+ TclOODeleteChain(clsPtr->constructorChainPtr);
+ clsPtr->constructorChainPtr = NULL;
+ }
+ if (clsPtr->destructorChainPtr) {
+ TclOODeleteChain(clsPtr->destructorChainPtr);
+ clsPtr->destructorChainPtr = NULL;
+ }
+ if (clsPtr->classChainCache) {
+ CallChain *callPtr;
+
+ FOREACH_HASH_VALUE(callPtr, clsPtr->classChainCache) {
+ TclOODeleteChain(callPtr);
+ }
+ Tcl_DeleteHashTable(clsPtr->classChainCache);
+ ckfree(clsPtr->classChainCache);
+ clsPtr->classChainCache = NULL;
+ }
+
+ /*
+ * Squelch our filter list.
+ */
+
+ if (clsPtr->filters.num) {
+ Tcl_Obj *filterObj;
+
+ FOREACH(filterObj, clsPtr->filters) {
+ TclDecrRefCount(filterObj);
+ }
+ ckfree(clsPtr->filters.list);
+ clsPtr->filters.num = 0;
+ }
+
+ /*
+ * Squelch our metadata.
+ */
+
+ if (clsPtr->metadataPtr != NULL) {
+ Tcl_ObjectMetadataType *metadataTypePtr;
+ ClientData value;
+
+ FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) {
+ metadataTypePtr->deleteProc(value);
+ }
+ Tcl_DeleteHashTable(clsPtr->metadataPtr);
+ ckfree(clsPtr->metadataPtr);
+ clsPtr->metadataPtr = NULL;
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ObjectNamespaceDeleted --
+ *
+ * Callback when the object's namespace is deleted. Used to clean up the
+ * data structures associated with the object. The complicated bit is
+ * that this can sometimes happen before the object's command is deleted
+ * (interpreter teardown is complex!)
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+ObjectNamespaceDeleted(
+ ClientData clientData) /* Pointer to the class whose namespace is
+ * being deleted. */
+{
+ Object *oPtr = clientData;
+ FOREACH_HASH_DECLS;
+ Class *clsPtr = oPtr->classPtr, *mixinPtr;
+ Method *mPtr;
+ Tcl_Obj *filterObj, *variableObj;
+ int deleteAlreadyInProgress = 0, i;
+
+ /*
+ * Instruct everyone to no longer use any allocated fields of the object.
+ * Also delete the commands that refer to the object at this point (if
+ * they still exist) because otherwise their references to the object
+ * point into freed memory, allowing crashes.
+ */
+
+ if (oPtr->command) {
+ if ((((Command *)oPtr->command)->flags && CMD_IS_DELETED)) {
+ /*
+ * Namespace deletion must have been triggered by a trace on command
+ * deletion , meaning that ObjectRenamedTrace() is eventually going
+ * to be called .
+ */
+ deleteAlreadyInProgress = 1;
+ }
+
+ Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command);
+ }
+ if (oPtr->myCommand) {
+ Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myCommand);
+ }
+
+ /*
+ * Splice the object out of its context. After this, we must *not* call
+ * methods on the object.
+ */
+
+ if (!IsRootObject(oPtr) && !(oPtr->flags & CLASS_GONE)) {
+ TclOORemoveFromInstances(oPtr, oPtr->selfCls);
+ }
+
+ FOREACH(mixinPtr, oPtr->mixins) {
+ if (mixinPtr) {
+ TclOORemoveFromInstances(oPtr, mixinPtr);
+ }
+ }
+ if (i) {
+ ckfree(oPtr->mixins.list);
+ }
+
+ FOREACH(filterObj, oPtr->filters) {
+ TclDecrRefCount(filterObj);
+ }
+ if (i) {
+ ckfree(oPtr->filters.list);
+ }
+
+ if (oPtr->methodsPtr) {
+ FOREACH_HASH_VALUE(mPtr, oPtr->methodsPtr) {
+ TclOODelMethodRef(mPtr);
+ }
+ Tcl_DeleteHashTable(oPtr->methodsPtr);
+ ckfree(oPtr->methodsPtr);
+ }
+
+ FOREACH(variableObj, oPtr->variables) {
+ TclDecrRefCount(variableObj);
+ }
+ if (i) {
+ ckfree(oPtr->variables.list);
+ }
+
+ if (oPtr->chainCache) {
+ TclOODeleteChainCache(oPtr->chainCache);
+ }
+
+ SquelchCachedName(oPtr);
+
+ if (oPtr->metadataPtr != NULL) {
+ Tcl_ObjectMetadataType *metadataTypePtr;
+ ClientData value;
+
+ FOREACH_HASH(metadataTypePtr, value, oPtr->metadataPtr) {
+ metadataTypePtr->deleteProc(value);
+ }
+ Tcl_DeleteHashTable(oPtr->metadataPtr);
+ ckfree(oPtr->metadataPtr);
+ oPtr->metadataPtr = NULL;
+ }
+
+ /*
+ * If this was a class, there's additional deletion work to do.
+ */
+
+ if (clsPtr != NULL) {
+ Tcl_ObjectMetadataType *metadataTypePtr;
+ ClientData value;
+
+ if (clsPtr->metadataPtr != NULL) {
+ FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) {
+ metadataTypePtr->deleteProc(value);
+ }
+ Tcl_DeleteHashTable(clsPtr->metadataPtr);
+ ckfree(clsPtr->metadataPtr);
+ clsPtr->metadataPtr = NULL;
+ }
+
+ FOREACH(filterObj, clsPtr->filters) {
+ TclDecrRefCount(filterObj);
+ }
+ if (i) {
+ ckfree(clsPtr->filters.list);
+ clsPtr->filters.num = 0;
+ }
+
+ ClearMixins(clsPtr);
+
+ ClearSuperclasses(clsPtr);
+
+ if (clsPtr->subclasses.list) {
+ ckfree(clsPtr->subclasses.list);
+ clsPtr->subclasses.list = NULL;
+ clsPtr->subclasses.num = 0;
+ }
+ if (clsPtr->instances.list) {
+ ckfree(clsPtr->instances.list);
+ clsPtr->instances.list = NULL;
+ clsPtr->instances.num = 0;
+ }
+ if (clsPtr->mixinSubs.list) {
+ ckfree(clsPtr->mixinSubs.list);
+ clsPtr->mixinSubs.list = NULL;
+ clsPtr->mixinSubs.num = 0;
+ }
+
+ FOREACH_HASH_VALUE(mPtr, &clsPtr->classMethods) {
+ TclOODelMethodRef(mPtr);
+ }
+ Tcl_DeleteHashTable(&clsPtr->classMethods);
+ TclOODelMethodRef(clsPtr->constructorPtr);
+ TclOODelMethodRef(clsPtr->destructorPtr);
+
+ FOREACH(variableObj, clsPtr->variables) {
+ TclDecrRefCount(variableObj);
+ }
+ if (i) {
+ ckfree(clsPtr->variables.list);
+ }
+
+ DelRef(clsPtr);
+ }
+
+ /*
+ * Delete the object structure itself.
+ */
+
+ if (deleteAlreadyInProgress) {
+ oPtr->classPtr = NULL;
+ oPtr->namespacePtr = NULL;
+ } else {
+ DelRef(oPtr);
+ }
+
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOORemoveFromInstances --
+ *
+ * Utility function to remove an object from the list of instances within
+ * a class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOORemoveFromInstances(
+ Object *oPtr, /* The instance to remove. */
+ Class *clsPtr) /* The class (possibly) containing the
+ * reference to the instance. */
+{
+ int i;
+ Object *instPtr;
+
+ FOREACH(instPtr, clsPtr->instances) {
+ if (oPtr == instPtr) {
+ goto removeInstance;
+ }
+ }
+ return;
+
+ removeInstance:
+ if (Deleted(clsPtr->thisPtr)) {
+ if (!IsRootClass(clsPtr)) {
+ DelRef(clsPtr->instances.list[i]);
+ }
+ clsPtr->instances.list[i] = NULL;
+ } else {
+ clsPtr->instances.num--;
+ if (i < clsPtr->instances.num) {
+ clsPtr->instances.list[i] =
+ clsPtr->instances.list[clsPtr->instances.num];
+ }
+ clsPtr->instances.list[clsPtr->instances.num] = NULL;
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOAddToInstances --
+ *
+ * Utility function to add an object to the list of instances within a
+ * class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOOAddToInstances(
+ Object *oPtr, /* The instance to add. */
+ Class *clsPtr) /* The class to add the instance to. It is
+ * assumed that the class is not already
+ * present as an instance in the class. */
+{
+ if (Deleted(clsPtr->thisPtr)) {
+ return;
+ }
+ if (clsPtr->instances.num >= clsPtr->instances.size) {
+ clsPtr->instances.size += ALLOC_CHUNK;
+ if (clsPtr->instances.size == ALLOC_CHUNK) {
+ clsPtr->instances.list = ckalloc(sizeof(Object *) * ALLOC_CHUNK);
+ } else {
+ clsPtr->instances.list = ckrealloc(clsPtr->instances.list,
+ sizeof(Object *) * clsPtr->instances.size);
+ }
+ }
+ clsPtr->instances.list[clsPtr->instances.num++] = oPtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOORemoveFromSubclasses --
+ *
+ * Utility function to remove a class from the list of subclasses within
+ * another class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOORemoveFromSubclasses(
+ Class *subPtr, /* The subclass to remove. */
+ Class *superPtr) /* The superclass to (possibly) remove the
+ * subclass reference from. */
+{
+ int i;
+ Class *subclsPtr;
+
+ FOREACH(subclsPtr, superPtr->subclasses) {
+ if (subPtr == subclsPtr) {
+ goto removeSubclass;
+ }
+ }
+ return;
+
+ removeSubclass:
+ if (!Deleted(superPtr->thisPtr)) {
+ superPtr->subclasses.num--;
+ if (i < superPtr->subclasses.num) {
+ superPtr->subclasses.list[i] =
+ superPtr->subclasses.list[superPtr->subclasses.num];
+ }
+ superPtr->subclasses.list[superPtr->subclasses.num] = NULL;
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOAddToSubclasses --
+ *
+ * Utility function to add a class to the list of subclasses within
+ * another class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOOAddToSubclasses(
+ Class *subPtr, /* The subclass to add. */
+ Class *superPtr) /* The superclass to add the subclass to. It
+ * is assumed that the class is not already
+ * present as a subclass in the superclass. */
+{
+ if (Deleted(superPtr->thisPtr)) {
+ return;
+ }
+ if (superPtr->subclasses.num >= superPtr->subclasses.size) {
+ superPtr->subclasses.size += ALLOC_CHUNK;
+ if (superPtr->subclasses.size == ALLOC_CHUNK) {
+ superPtr->subclasses.list = ckalloc(sizeof(Class*) * ALLOC_CHUNK);
+ } else {
+ superPtr->subclasses.list = ckrealloc(superPtr->subclasses.list,
+ sizeof(Class *) * superPtr->subclasses.size);
+ }
+ }
+ superPtr->subclasses.list[superPtr->subclasses.num++] = subPtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOORemoveFromMixinSubs --
+ *
+ * Utility function to remove a class from the list of mixinSubs within
+ * another class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOORemoveFromMixinSubs(
+ Class *subPtr, /* The subclass to remove. */
+ Class *superPtr) /* The superclass to (possibly) remove the
+ * subclass reference from. */
+{
+ int i;
+ Class *subclsPtr;
+
+ FOREACH(subclsPtr, superPtr->mixinSubs) {
+ if (subPtr == subclsPtr) {
+ goto removeSubclass;
+ }
+ }
+ return;
+
+ removeSubclass:
+ if (!Deleted(superPtr->thisPtr)) {
+ superPtr->mixinSubs.num--;
+ if (i < superPtr->mixinSubs.num) {
+ superPtr->mixinSubs.list[i] =
+ superPtr->mixinSubs.list[superPtr->mixinSubs.num];
+ }
+ superPtr->mixinSubs.list[superPtr->mixinSubs.num] = NULL;
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOAddToMixinSubs --
+ *
+ * Utility function to add a class to the list of mixinSubs within
+ * another class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOOAddToMixinSubs(
+ Class *subPtr, /* The subclass to add. */
+ Class *superPtr) /* The superclass to add the subclass to. It
+ * is assumed that the class is not already
+ * present as a subclass in the superclass. */
+{
+ if (Deleted(superPtr->thisPtr)) {
+ return;
+ }
+ if (superPtr->mixinSubs.num >= superPtr->mixinSubs.size) {
+ superPtr->mixinSubs.size += ALLOC_CHUNK;
+ if (superPtr->mixinSubs.size == ALLOC_CHUNK) {
+ superPtr->mixinSubs.list = ckalloc(sizeof(Class *) * ALLOC_CHUNK);
+ } else {
+ superPtr->mixinSubs.list = ckrealloc(superPtr->mixinSubs.list,
+ sizeof(Class *) * superPtr->mixinSubs.size);
+ }
+ }
+ superPtr->mixinSubs.list[superPtr->mixinSubs.num++] = subPtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AllocClass --
+ *
+ * Allocate a basic class. Does not splice the class object into its
+ * class's instance list.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static Class *
+AllocClass(
+ Tcl_Interp *interp, /* Interpreter within which to allocate the
+ * class. */
+ Object *useThisObj) /* Object that is to act as the class
+ * representation, or NULL if a new object
+ * (with automatic name) is to be used. */
+{
+ Foundation *fPtr = GetFoundation(interp);
+ Class *clsPtr = ckalloc(sizeof(Class));
+
+ /*
+ * Make an object if we haven't been given one.
+ */
+
+ memset(clsPtr, 0, sizeof(Class));
+ if (useThisObj == NULL) {
+ clsPtr->thisPtr = AllocObject(interp, NULL, NULL);
+ } else {
+ clsPtr->thisPtr = useThisObj;
+ }
+
+ /*
+ * Configure the namespace path for the class's object.
+ */
+
+ if (fPtr->helpersNs != NULL) {
+ Tcl_Namespace *path[2];
+
+ path[0] = fPtr->helpersNs;
+ path[1] = fPtr->ooNs;
+ TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 2, path);
+ } else {
+ TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 1,
+ &fPtr->ooNs);
+ }
+
+ /*
+ * Class objects inherit from the class of classes unless they inherit
+ * from some subclass of it. Enforce this right now.
+ */
+
+ clsPtr->thisPtr->selfCls = fPtr->classCls;
+
+ /*
+ * Classes are subclasses of oo::object, i.e. the objects they create are
+ * objects.
+ */
+
+ clsPtr->superclasses.num = 1;
+ clsPtr->superclasses.list = ckalloc(sizeof(Class *));
+ clsPtr->superclasses.list[0] = fPtr->objectCls;
+
+ /*
+ * Finish connecting the class structure to the object structure.
+ */
+
+ clsPtr->thisPtr->classPtr = clsPtr;
+
+ /*
+ * That's the complicated bit. Now fill in the rest of the non-zero/NULL
+ * fields.
+ */
+
+ clsPtr->refCount = 1;
+ Tcl_InitObjHashTable(&clsPtr->classMethods);
+ return clsPtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Tcl_NewObjectInstance --
+ *
+ * Allocate a new instance of an object.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Tcl_Object
+Tcl_NewObjectInstance(
+ Tcl_Interp *interp, /* Interpreter context. */
+ Tcl_Class cls, /* Class to create an instance of. */
+ const char *nameStr, /* Name of object to create, or NULL to ask
+ * the code to pick its own unique name. */
+ const char *nsNameStr, /* Name of namespace to create inside object,
+ * or NULL to ask the code to pick its own
+ * unique name. */
+ int objc, /* Number of arguments. Negative value means
+ * do not call constructor. */
+ Tcl_Obj *const *objv, /* Argument list. */
+ int skip) /* Number of arguments to _not_ pass to the
+ * constructor. */
+{
+ register Class *classPtr = (Class *) cls;
+ Foundation *fPtr = GetFoundation(interp);
+ Object *oPtr;
+
+ /*
+ * Check if we're going to create an object over an existing command;
+ * that's not allowed.
+ */
+
+ if (nameStr && Tcl_FindCommand(interp, nameStr, NULL,
+ TCL_NAMESPACE_ONLY)) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't create object \"%s\": command already exists with"
+ " that name", nameStr));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL);
+ return NULL;
+ }
+
+ /*
+ * Create the object.
+ */
+
+ oPtr = AllocObject(interp, nameStr, nsNameStr);
+ oPtr->selfCls = classPtr;
+ TclOOAddToInstances(oPtr, classPtr);
+
+ /*
+ * Check to see if we're really creating a class. If so, allocate the
+ * class structure as well.
+ */
+
+ if (TclOOIsReachable(fPtr->classCls, classPtr)) {
+ /*
+ * Is a class, so attach a class structure. Note that the AllocClass
+ * function splices the structure into the object, so we don't have
+ * to. Once that's done, we need to repatch the object to have the
+ * right class since AllocClass interferes with that.
+ */
+
+ AllocClass(interp, oPtr);
+ oPtr->selfCls = classPtr;
+ TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls);
+ } else {
+ oPtr->classPtr = NULL;
+ }
+
+ /*
+ * Run constructors, except when objc < 0 (a special flag case used for
+ * object cloning only).
+ */
+
+ if (objc >= 0) {
+ CallContext *contextPtr =
+ TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL);
+
+ if (contextPtr != NULL) {
+ int isRoot, result;
+ Tcl_InterpState state;
+
+ state = Tcl_SaveInterpState(interp, TCL_OK);
+ contextPtr->callPtr->flags |= CONSTRUCTOR;
+ contextPtr->skip = skip;
+
+ /*
+ * Adjust the ensmble tracking record if necessary. [Bug 3514761]
+ */
+
+ isRoot = TclInitRewriteEnsemble(interp, skip, skip, objv);
+ result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr,
+ objc, objv);
+
+ if (isRoot) {
+ TclResetRewriteEnsemble(interp, 1);
+ }
+
+ /*
+ * It's an error if the object was whacked in the constructor.
+ * Force this if it isn't already an error (don't want to lose
+ * errors by accident...) [Bug 2903011]
+ */
+
+ if (result != TCL_ERROR && Deleted(oPtr)) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "object deleted in constructor", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL);
+ result = TCL_ERROR;
+ }
+ TclOODeleteContext(contextPtr);
+ if (result != TCL_OK) {
+ Tcl_DiscardInterpState(state);
+
+ /*
+ * Take care to not delete a deleted object; that would be
+ * bad. [Bug 2903011] Also take care to make sure that we have
+ * the name of the command before we delete it. [Bug
+ * 9dd1bd7a74]
+ */
+
+ if (!Deleted(oPtr)) {
+ (void) TclOOObjectName(interp, oPtr);
+ Tcl_DeleteCommandFromToken(interp, oPtr->command);
+ }
+ return NULL;
+ }
+ Tcl_RestoreInterpState(interp, state);
+ }
+ }
+
+ return (Tcl_Object) oPtr;
+}
+
+int
+TclNRNewObjectInstance(
+ Tcl_Interp *interp, /* Interpreter context. */
+ Tcl_Class cls, /* Class to create an instance of. */
+ const char *nameStr, /* Name of object to create, or NULL to ask
+ * the code to pick its own unique name. */
+ const char *nsNameStr, /* Name of namespace to create inside object,
+ * or NULL to ask the code to pick its own
+ * unique name. */
+ int objc, /* Number of arguments. Negative value means
+ * do not call constructor. */
+ Tcl_Obj *const *objv, /* Argument list. */
+ int skip, /* Number of arguments to _not_ pass to the
+ * constructor. */
+ Tcl_Object *objectPtr) /* Place to write the object reference upon
+ * successful allocation. */
+{
+ register Class *classPtr = (Class *) cls;
+ Foundation *fPtr = GetFoundation(interp);
+ CallContext *contextPtr;
+ Tcl_InterpState state;
+ Object *oPtr;
+
+ /*
+ * Protect classPtr from getting cleaned up when the command is created.
+ */
+ AddRef(classPtr);
+
+ /*
+ * Check if we're going to create an object over an existing command;
+ * that's not allowed.
+ */
+
+ if (nameStr && Tcl_FindCommand(interp, nameStr, NULL,
+ TCL_NAMESPACE_ONLY)) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't create object \"%s\": command already exists with"
+ " that name", nameStr));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Create the object.
+ */
+
+ oPtr = AllocObject(interp, nameStr, nsNameStr);
+ oPtr->selfCls = classPtr;
+ TclOOAddToInstances(oPtr, classPtr);
+
+ /*
+ * Check to see if we're really creating a class. If so, allocate the
+ * class structure as well.
+ */
+
+ if (TclOOIsReachable(fPtr->classCls, classPtr)) {
+ /*
+ * Is a class, so attach a class structure. Note that the AllocClass
+ * function splices the structure into the object, so we don't have
+ * to. Once that's done, we need to repatch the object to have the
+ * right class since AllocClass interferes with that.
+ */
+
+ AllocClass(interp, oPtr);
+ oPtr->selfCls = classPtr;
+ TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls);
+ }
+
+ /*
+ * Run constructors, except when objc < 0 (a special flag case used for
+ * object cloning only). If there aren't any constructors, we do nothing.
+ */
+
+ if (objc < 0) {
+ *objectPtr = (Tcl_Object) oPtr;
+ DelRef(classPtr);
+ return TCL_OK;
+ }
+ contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL);
+ if (contextPtr == NULL) {
+ *objectPtr = (Tcl_Object) oPtr;
+ DelRef(classPtr);
+ return TCL_OK;
+ }
+
+ state = Tcl_SaveInterpState(interp, TCL_OK);
+ contextPtr->callPtr->flags |= CONSTRUCTOR;
+ contextPtr->skip = skip;
+
+ /*
+ * Adjust the ensmble tracking record if necessary. [Bug 3514761]
+ */
+
+ if (TclInitRewriteEnsemble(interp, skip, skip, objv)) {
+ TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
+ }
+
+ /*
+ * Fire off the constructors non-recursively.
+ */
+
+ AddRef(oPtr);
+ TclNRAddCallback(interp, FinalizeAlloc, contextPtr, oPtr, state,
+ objectPtr);
+ TclPushTailcallPoint(interp);
+ DelRef(classPtr);
+ return TclOOInvokeContext(contextPtr, interp, objc, objv);
+}
+
+static int
+FinalizeAlloc(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ CallContext *contextPtr = data[0];
+ Object *oPtr = data[1];
+ Tcl_InterpState state = data[2];
+ Tcl_Object *objectPtr = data[3];
+
+ /*
+ * It's an error if the object was whacked in the constructor. Force this
+ * if it isn't already an error (don't want to lose errors by accident...)
+ * [Bug 2903011]
+ */
+
+ if (result != TCL_ERROR && Deleted(oPtr)) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "object deleted in constructor", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL);
+ result = TCL_ERROR;
+ }
+ TclOODeleteContext(contextPtr);
+ if (result != TCL_OK) {
+ Tcl_DiscardInterpState(state);
+
+ /*
+ * Take care to not delete a deleted object; that would be bad. [Bug
+ * 2903011] Also take care to make sure that we have the name of the
+ * command before we delete it. [Bug 9dd1bd7a74]
+ */
+
+ if (!Deleted(oPtr)) {
+ (void) TclOOObjectName(interp, oPtr);
+ Tcl_DeleteCommandFromToken(interp, oPtr->command);
+ }
+ DelRef(oPtr);
+ return TCL_ERROR;
+ }
+ Tcl_RestoreInterpState(interp, state);
+ *objectPtr = (Tcl_Object) oPtr;
+ DelRef(oPtr);
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Tcl_CopyObjectInstance --
+ *
+ * Creates a copy of an object. Does not copy the backing namespace,
+ * since the correct way to do that (e.g., shallow/deep) depends on the
+ * object/class's own policies.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Tcl_Object
+Tcl_CopyObjectInstance(
+ Tcl_Interp *interp,
+ Tcl_Object sourceObject,
+ const char *targetName,
+ const char *targetNamespaceName)
+{
+ Object *oPtr = (Object *) sourceObject, *o2Ptr;
+ FOREACH_HASH_DECLS;
+ Method *mPtr;
+ Class *mixinPtr;
+ CallContext *contextPtr;
+ Tcl_Obj *keyPtr, *filterObj, *variableObj, *args[3];
+ int i, result;
+
+ /*
+ * Sanity check.
+ */
+
+ if (IsRootClass(oPtr)) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "may not clone the class of classes", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CLONING_CLASS", NULL);
+ return NULL;
+ }
+
+ /*
+ * Build the instance. Note that this does not run any constructors.
+ */
+
+ o2Ptr = (Object *) Tcl_NewObjectInstance(interp,
+ (Tcl_Class) oPtr->selfCls, targetName, targetNamespaceName, -1,
+ NULL, -1);
+ if (o2Ptr == NULL) {
+ return NULL;
+ }
+
+ /*
+ * Copy the object-local methods to the new object.
+ */
+
+ if (oPtr->methodsPtr) {
+ FOREACH_HASH(keyPtr, mPtr, oPtr->methodsPtr) {
+ if (CloneObjectMethod(interp, o2Ptr, mPtr, keyPtr) != TCL_OK) {
+ Tcl_DeleteCommandFromToken(interp, o2Ptr->command);
+ return NULL;
+ }
+ }
+ }
+
+ /*
+ * Copy the object's mixin references to the new object.
+ */
+
+ FOREACH(mixinPtr, o2Ptr->mixins) {
+ if (mixinPtr && mixinPtr != o2Ptr->selfCls) {
+ TclOORemoveFromInstances(o2Ptr, mixinPtr);
+ }
+ }
+ DUPLICATE(o2Ptr->mixins, oPtr->mixins, Class *);
+ FOREACH(mixinPtr, o2Ptr->mixins) {
+ if (mixinPtr && mixinPtr != o2Ptr->selfCls) {
+ TclOOAddToInstances(o2Ptr, mixinPtr);
+ }
+ }
+
+ /*
+ * Copy the object's filter list to the new object.
+ */
+
+ DUPLICATE(o2Ptr->filters, oPtr->filters, Tcl_Obj *);
+ FOREACH(filterObj, o2Ptr->filters) {
+ Tcl_IncrRefCount(filterObj);
+ }
+
+ /*
+ * Copy the object's variable resolution list to the new object.
+ */
+
+ DUPLICATE(o2Ptr->variables, oPtr->variables, Tcl_Obj *);
+ FOREACH(variableObj, o2Ptr->variables) {
+ Tcl_IncrRefCount(variableObj);
+ }
+
+ /*
+ * Copy the object's flags to the new object, clearing those that must be
+ * kept object-local. The duplicate is never deleted at this point, nor is
+ * it the root of the object system or in the midst of processing a filter
+ * call.
+ */
+
+ o2Ptr->flags = oPtr->flags & ~(
+ OBJECT_DELETED | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING);
+
+ /*
+ * Copy the object's metadata.
+ */
+
+ if (oPtr->metadataPtr != NULL) {
+ Tcl_ObjectMetadataType *metadataTypePtr;
+ ClientData value, duplicate;
+
+ FOREACH_HASH(metadataTypePtr, value, oPtr->metadataPtr) {
+ if (metadataTypePtr->cloneProc == NULL) {
+ duplicate = value;
+ } else {
+ if (metadataTypePtr->cloneProc(interp, value,
+ &duplicate) != TCL_OK) {
+ Tcl_DeleteCommandFromToken(interp, o2Ptr->command);
+ return NULL;
+ }
+ }
+ if (duplicate != NULL) {
+ Tcl_ObjectSetMetadata((Tcl_Object) o2Ptr, metadataTypePtr,
+ duplicate);
+ }
+ }
+ }
+
+ /*
+ * Copy the class, if present. Note that if there is a class present in
+ * the source object, there must also be one in the copy.
+ */
+
+ if (oPtr->classPtr != NULL) {
+ Class *clsPtr = oPtr->classPtr;
+ Class *cls2Ptr = o2Ptr->classPtr;
+ Class *superPtr;
+
+ /*
+ * Copy the class flags across.
+ */
+
+ cls2Ptr->flags = clsPtr->flags;
+
+ /*
+ * Ensure that the new class's superclass structure is the same as the
+ * old class's.
+ */
+
+ FOREACH(superPtr, cls2Ptr->superclasses) {
+ TclOORemoveFromSubclasses(cls2Ptr, superPtr);
+ }
+ if (cls2Ptr->superclasses.num) {
+ cls2Ptr->superclasses.list = ckrealloc(cls2Ptr->superclasses.list,
+ sizeof(Class *) * clsPtr->superclasses.num);
+ } else {
+ cls2Ptr->superclasses.list =
+ ckalloc(sizeof(Class *) * clsPtr->superclasses.num);
+ }
+ memcpy(cls2Ptr->superclasses.list, clsPtr->superclasses.list,
+ sizeof(Class *) * clsPtr->superclasses.num);
+ cls2Ptr->superclasses.num = clsPtr->superclasses.num;
+ FOREACH(superPtr, cls2Ptr->superclasses) {
+ TclOOAddToSubclasses(cls2Ptr, superPtr);
+ }
+
+ /*
+ * Duplicate the source class's filters.
+ */
+
+ DUPLICATE(cls2Ptr->filters, clsPtr->filters, Tcl_Obj *);
+ FOREACH(filterObj, cls2Ptr->filters) {
+ Tcl_IncrRefCount(filterObj);
+ }
+
+ /*
+ * Copy the source class's variable resolution list.
+ */
+
+ DUPLICATE(cls2Ptr->variables, clsPtr->variables, Tcl_Obj *);
+ FOREACH(variableObj, cls2Ptr->variables) {
+ Tcl_IncrRefCount(variableObj);
+ }
+
+ /*
+ * Duplicate the source class's mixins (which cannot be circular
+ * references to the duplicate).
+ */
+
+ FOREACH(mixinPtr, cls2Ptr->mixins) {
+ TclOORemoveFromMixinSubs(cls2Ptr, mixinPtr);
+ }
+ if (cls2Ptr->mixins.num != 0) {
+ ckfree(clsPtr->mixins.list);
+ }
+ DUPLICATE(cls2Ptr->mixins, clsPtr->mixins, Class *);
+ FOREACH(mixinPtr, cls2Ptr->mixins) {
+ TclOOAddToMixinSubs(cls2Ptr, mixinPtr);
+ }
+
+ /*
+ * Duplicate the source class's methods, constructor and destructor.
+ */
+
+ FOREACH_HASH(keyPtr, mPtr, &clsPtr->classMethods) {
+ if (CloneClassMethod(interp, cls2Ptr, mPtr, keyPtr,
+ NULL) != TCL_OK) {
+ Tcl_DeleteCommandFromToken(interp, o2Ptr->command);
+ return NULL;
+ }
+ }
+ if (clsPtr->constructorPtr) {
+ if (CloneClassMethod(interp, cls2Ptr, clsPtr->constructorPtr,
+ NULL, &cls2Ptr->constructorPtr) != TCL_OK) {
+ Tcl_DeleteCommandFromToken(interp, o2Ptr->command);
+ return NULL;
+ }
+ }
+ if (clsPtr->destructorPtr) {
+ if (CloneClassMethod(interp, cls2Ptr, clsPtr->destructorPtr, NULL,
+ &cls2Ptr->destructorPtr) != TCL_OK) {
+ Tcl_DeleteCommandFromToken(interp, o2Ptr->command);
+ return NULL;
+ }
+ }
+
+ /*
+ * Duplicate the class's metadata.
+ */
+
+ if (clsPtr->metadataPtr != NULL) {
+ Tcl_ObjectMetadataType *metadataTypePtr;
+ ClientData value, duplicate;
+
+ FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) {
+ if (metadataTypePtr->cloneProc == NULL) {
+ duplicate = value;
+ } else {
+ if (metadataTypePtr->cloneProc(interp, value,
+ &duplicate) != TCL_OK) {
+ Tcl_DeleteCommandFromToken(interp, o2Ptr->command);
+ return NULL;
+ }
+ }
+ if (duplicate != NULL) {
+ Tcl_ClassSetMetadata((Tcl_Class) cls2Ptr, metadataTypePtr,
+ duplicate);
+ }
+ }
+ }
+ }
+
+ TclResetRewriteEnsemble(interp, 1);
+ contextPtr = TclOOGetCallContext(o2Ptr, oPtr->fPtr->clonedName, 0, NULL);
+ if (contextPtr) {
+ args[0] = TclOOObjectName(interp, o2Ptr);
+ args[1] = oPtr->fPtr->clonedName;
+ args[2] = TclOOObjectName(interp, oPtr);
+ Tcl_IncrRefCount(args[0]);
+ Tcl_IncrRefCount(args[1]);
+ Tcl_IncrRefCount(args[2]);
+ result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr, 3,
+ args);
+ TclDecrRefCount(args[0]);
+ TclDecrRefCount(args[1]);
+ TclDecrRefCount(args[2]);
+ TclOODeleteContext(contextPtr);
+ if (result == TCL_ERROR) {
+ Tcl_AddErrorInfo(interp,
+ "\n (while performing post-copy callback)");
+ }
+ if (result != TCL_OK) {
+ Tcl_DeleteCommandFromToken(interp, o2Ptr->command);
+ return NULL;
+ }
+ }
+
+ return (Tcl_Object) o2Ptr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * CloneObjectMethod, CloneClassMethod --
+ *
+ * Helper functions used for cloning methods. They work identically to
+ * each other, except for the difference between them in how they
+ * register the cloned method on a successful clone.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+CloneObjectMethod(
+ Tcl_Interp *interp,
+ Object *oPtr,
+ Method *mPtr,
+ Tcl_Obj *namePtr)
+{
+ if (mPtr->typePtr == NULL) {
+ Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr,
+ mPtr->flags & PUBLIC_METHOD, NULL, NULL);
+ } else if (mPtr->typePtr->cloneProc) {
+ ClientData newClientData;
+
+ if (mPtr->typePtr->cloneProc(interp, mPtr->clientData,
+ &newClientData) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr,
+ mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, newClientData);
+ } else {
+ Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr,
+ mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, mPtr->clientData);
+ }
+ return TCL_OK;
+}
+
+static int
+CloneClassMethod(
+ Tcl_Interp *interp,
+ Class *clsPtr,
+ Method *mPtr,
+ Tcl_Obj *namePtr,
+ Method **m2PtrPtr)
+{
+ Method *m2Ptr;
+
+ if (mPtr->typePtr == NULL) {
+ m2Ptr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr,
+ namePtr, mPtr->flags & PUBLIC_METHOD, NULL, NULL);
+ } else if (mPtr->typePtr->cloneProc) {
+ ClientData newClientData;
+
+ if (mPtr->typePtr->cloneProc(interp, mPtr->clientData,
+ &newClientData) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ m2Ptr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr,
+ namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr,
+ newClientData);
+ } else {
+ m2Ptr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr,
+ namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr,
+ mPtr->clientData);
+ }
+ if (m2PtrPtr != NULL) {
+ *m2PtrPtr = m2Ptr;
+ }
+ return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Tcl_ClassGetMetadata, Tcl_ClassSetMetadata, Tcl_ObjectGetMetadata,
+ * Tcl_ObjectSetMetadata --
+ *
+ * Metadata management API. The metadata system allows code in extensions
+ * to attach arbitrary non-NULL pointers to objects and classes without
+ * the different things that might be interested being able to interfere
+ * with each other. Apart from non-NULL-ness, these routines attach no
+ * interpretation to the meaning of the metadata pointers.
+ *
+ * The Tcl_*GetMetadata routines get the metadata pointer attached that
+ * has been related with a particular type, or NULL if no metadata
+ * associated with the given type has been attached.
+ *
+ * The Tcl_*SetMetadata routines set or delete the metadata pointer that
+ * is related to a particular type. The value associated with the type is
+ * deleted (if present; no-op otherwise) if the value is NULL, and
+ * attached (replacing the previous value, which is deleted if present)
+ * otherwise. This means it is impossible to attach a NULL value for any
+ * metadata type.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+ClientData
+Tcl_ClassGetMetadata(
+ Tcl_Class clazz,
+ const Tcl_ObjectMetadataType *typePtr)
+{
+ Class *clsPtr = (Class *) clazz;
+ Tcl_HashEntry *hPtr;
+
+ /*
+ * If there's no metadata store attached, the type in question has
+ * definitely not been attached either!
+ */
+
+ if (clsPtr->metadataPtr == NULL) {
+ return NULL;
+ }
+
+ /*
+ * There is a metadata store, so look in it for the given type.
+ */
+
+ hPtr = Tcl_FindHashEntry(clsPtr->metadataPtr, (char *) typePtr);
+
+ /*
+ * Return the metadata value if we found it, otherwise NULL.
+ */
+
+ if (hPtr == NULL) {
+ return NULL;
+ }
+ return Tcl_GetHashValue(hPtr);
+}
+
+void
+Tcl_ClassSetMetadata(
+ Tcl_Class clazz,
+ const Tcl_ObjectMetadataType *typePtr,
+ ClientData metadata)
+{
+ Class *clsPtr = (Class *) clazz;
+ Tcl_HashEntry *hPtr;
+ int isNew;
+
+ /*
+ * Attach the metadata store if not done already.
+ */
+
+ if (clsPtr->metadataPtr == NULL) {
+ if (metadata == NULL) {
+ return;
+ }
+ clsPtr->metadataPtr = ckalloc(sizeof(Tcl_HashTable));
+ Tcl_InitHashTable(clsPtr->metadataPtr, TCL_ONE_WORD_KEYS);
+ }
+
+ /*
+ * If the metadata is NULL, we're deleting the metadata for the type.
+ */
+
+ if (metadata == NULL) {
+ hPtr = Tcl_FindHashEntry(clsPtr->metadataPtr, (char *) typePtr);
+ if (hPtr != NULL) {
+ typePtr->deleteProc(Tcl_GetHashValue(hPtr));
+ Tcl_DeleteHashEntry(hPtr);
+ }
+ return;
+ }
+
+ /*
+ * Otherwise we're attaching the metadata. Note that if there was already
+ * some metadata attached of this type, we delete that first.
+ */
+
+ hPtr = Tcl_CreateHashEntry(clsPtr->metadataPtr, (char *) typePtr, &isNew);
+ if (!isNew) {
+ typePtr->deleteProc(Tcl_GetHashValue(hPtr));
+ }
+ Tcl_SetHashValue(hPtr, metadata);
+}
+
+ClientData
+Tcl_ObjectGetMetadata(
+ Tcl_Object object,
+ const Tcl_ObjectMetadataType *typePtr)
+{
+ Object *oPtr = (Object *) object;
+ Tcl_HashEntry *hPtr;
+
+ /*
+ * If there's no metadata store attached, the type in question has
+ * definitely not been attached either!
+ */
+
+ if (oPtr->metadataPtr == NULL) {
+ return NULL;
+ }
+
+ /*
+ * There is a metadata store, so look in it for the given type.
+ */
+
+ hPtr = Tcl_FindHashEntry(oPtr->metadataPtr, (char *) typePtr);
+
+ /*
+ * Return the metadata value if we found it, otherwise NULL.
+ */
+
+ if (hPtr == NULL) {
+ return NULL;
+ }
+ return Tcl_GetHashValue(hPtr);
+}
+
+void
+Tcl_ObjectSetMetadata(
+ Tcl_Object object,
+ const Tcl_ObjectMetadataType *typePtr,
+ ClientData metadata)
+{
+ Object *oPtr = (Object *) object;
+ Tcl_HashEntry *hPtr;
+ int isNew;
+
+ /*
+ * Attach the metadata store if not done already.
+ */
+
+ if (oPtr->metadataPtr == NULL) {
+ if (metadata == NULL) {
+ return;
+ }
+ oPtr->metadataPtr = ckalloc(sizeof(Tcl_HashTable));
+ Tcl_InitHashTable(oPtr->metadataPtr, TCL_ONE_WORD_KEYS);
+ }
+
+ /*
+ * If the metadata is NULL, we're deleting the metadata for the type.
+ */
+
+ if (metadata == NULL) {
+ hPtr = Tcl_FindHashEntry(oPtr->metadataPtr, (char *) typePtr);
+ if (hPtr != NULL) {
+ typePtr->deleteProc(Tcl_GetHashValue(hPtr));
+ Tcl_DeleteHashEntry(hPtr);
+ }
+ return;
+ }
+
+ /*
+ * Otherwise we're attaching the metadata. Note that if there was already
+ * some metadata attached of this type, we delete that first.
+ */
+
+ hPtr = Tcl_CreateHashEntry(oPtr->metadataPtr, (char *) typePtr, &isNew);
+ if (!isNew) {
+ typePtr->deleteProc(Tcl_GetHashValue(hPtr));
+ }
+ Tcl_SetHashValue(hPtr, metadata);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * PublicObjectCmd, PrivateObjectCmd, TclOOInvokeObject --
+ *
+ * Main entry point for object invocations. The Public* and Private*
+ * wrapper functions (implementations of both object instance commands
+ * and [my]) are just thin wrappers round the main TclOOObjectCmdCore
+ * function. Note that the core is function is NRE-aware.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+PublicObjectCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ return Tcl_NRCallObjProc(interp, PublicNRObjectCmd, clientData,objc,objv);
+}
+
+static int
+PublicNRObjectCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ return TclOOObjectCmdCore(clientData, interp, objc, objv, PUBLIC_METHOD,
+ NULL);
+}
+
+static int
+PrivateObjectCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ return Tcl_NRCallObjProc(interp, PrivateNRObjectCmd,clientData,objc,objv);
+}
+
+static int
+PrivateNRObjectCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ return TclOOObjectCmdCore(clientData, interp, objc, objv, 0, NULL);
+}
+
+int
+TclOOInvokeObject(
+ Tcl_Interp *interp, /* Interpreter for commands, variables,
+ * results, error reporting, etc. */
+ Tcl_Object object, /* The object to invoke. */
+ Tcl_Class startCls, /* Where in the class chain to start the
+ * invoke from, or NULL to traverse the whole
+ * chain including filters. */
+ int publicPrivate, /* Whether this is an invoke from a public
+ * context (PUBLIC_METHOD), a private context
+ * (PRIVATE_METHOD), or a *really* private
+ * context (any other value; conventionally
+ * 0). */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const *objv) /* Array of argument objects. It is assumed
+ * that the name of the method to invoke will
+ * be at index 1. */
+{
+ switch (publicPrivate) {
+ case PUBLIC_METHOD:
+ return TclOOObjectCmdCore((Object *) object, interp, objc, objv,
+ PUBLIC_METHOD, (Class *) startCls);
+ case PRIVATE_METHOD:
+ return TclOOObjectCmdCore((Object *) object, interp, objc, objv,
+ PRIVATE_METHOD, (Class *) startCls);
+ default:
+ return TclOOObjectCmdCore((Object *) object, interp, objc, objv, 0,
+ (Class *) startCls);
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOObjectCmdCore, FinalizeObjectCall --
+ *
+ * Main function for object invocations. Does call chain creation,
+ * management and invocation. The function FinalizeObjectCall exists to
+ * clean up after the non-recursive processing of TclOOObjectCmdCore.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOOObjectCmdCore(
+ Object *oPtr, /* The object being invoked. */
+ Tcl_Interp *interp, /* The interpreter containing the object. */
+ int objc, /* How many arguments are being passed in. */
+ Tcl_Obj *const *objv, /* The array of arguments. */
+ int flags, /* Whether this is an invocation through the
+ * public or the private command interface. */
+ Class *startCls) /* Where to start in the call chain, or NULL
+ * if we are to start at the front with
+ * filters and the object's methods (which is
+ * the normal case). */
+{
+ CallContext *contextPtr;
+ Tcl_Obj *methodNamePtr;
+ int result;
+
+ /*
+ * If we've no method name, throw this directly into the unknown
+ * processing.
+ */
+
+ if (objc < 2) {
+ flags |= FORCE_UNKNOWN;
+ methodNamePtr = NULL;
+ goto noMapping;
+ }
+
+ /*
+ * Give plugged in code a chance to remap the method name.
+ */
+
+ methodNamePtr = objv[1];
+ if (oPtr->mapMethodNameProc != NULL) {
+ register Class **startClsPtr = &startCls;
+ Tcl_Obj *mappedMethodName = Tcl_DuplicateObj(methodNamePtr);
+
+ result = oPtr->mapMethodNameProc(interp, (Tcl_Object) oPtr,
+ (Tcl_Class *) startClsPtr, mappedMethodName);
+ if (result != TCL_OK) {
+ TclDecrRefCount(mappedMethodName);
+ if (result == TCL_BREAK) {
+ goto noMapping;
+ } else if (result == TCL_ERROR) {
+ Tcl_AddErrorInfo(interp, "\n (while mapping method name)");
+ }
+ return result;
+ }
+
+ /*
+ * Get the call chain for the remapped name.
+ */
+
+ Tcl_IncrRefCount(mappedMethodName);
+ contextPtr = TclOOGetCallContext(oPtr, mappedMethodName,
+ flags | (oPtr->flags & FILTER_HANDLING), methodNamePtr);
+ TclDecrRefCount(mappedMethodName);
+ if (contextPtr == NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "impossible to invoke method \"%s\": no defined method or"
+ " unknown method", TclGetString(methodNamePtr)));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD_MAPPED",
+ TclGetString(methodNamePtr), NULL);
+ return TCL_ERROR;
+ }
+ } else {
+ /*
+ * Get the call chain.
+ */
+
+ noMapping:
+ contextPtr = TclOOGetCallContext(oPtr, methodNamePtr,
+ flags | (oPtr->flags & FILTER_HANDLING), NULL);
+ if (contextPtr == NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "impossible to invoke method \"%s\": no defined method or"
+ " unknown method", TclGetString(methodNamePtr)));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+ TclGetString(methodNamePtr), NULL);
+ return TCL_ERROR;
+ }
+ }
+
+ /*
+ * Check to see if we need to apply magical tricks to start part way
+ * through the call chain.
+ */
+
+ if (startCls != NULL) {
+ for (; contextPtr->index < contextPtr->callPtr->numChain;
+ contextPtr->index++) {
+ register struct MInvoke *miPtr =
+ &contextPtr->callPtr->chain[contextPtr->index];
+
+ if (miPtr->isFilter) {
+ continue;
+ }
+ if (miPtr->mPtr->declaringClassPtr == startCls) {
+ break;
+ }
+ }
+ if (contextPtr->index >= contextPtr->callPtr->numChain) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "no valid method implementation", -1));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+ TclGetString(methodNamePtr), NULL);
+ TclOODeleteContext(contextPtr);
+ return TCL_ERROR;
+ }
+ }
+
+ /*
+ * Invoke the call chain, locking the object structure against deletion
+ * for the duration.
+ */
+
+ TclNRAddCallback(interp, FinalizeObjectCall, contextPtr, NULL,NULL,NULL);
+ return TclOOInvokeContext(contextPtr, interp, objc, objv);
+}
+
+static int
+FinalizeObjectCall(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ /*
+ * Dispose of the call chain, which drops the lock on the object's
+ * structure.
+ */
+
+ TclOODeleteContext(data[0]);
+ return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Tcl_ObjectContextInvokeNext, TclNRObjectContextInvokeNext, FinalizeNext --
+ *
+ * Invokes the next stage of the call chain described in an object
+ * context. This is the core of the implementation of the [next] command.
+ * Does not do management of the call-frame stack. Available in public
+ * (standard API) and private (NRE-aware) forms. FinalizeNext is a
+ * private function used to clean up in the NRE case.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+Tcl_ObjectContextInvokeNext(
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv,
+ int skip)
+{
+ CallContext *contextPtr = (CallContext *) context;
+ int savedIndex = contextPtr->index;
+ int savedSkip = contextPtr->skip;
+ int result;
+
+ if (contextPtr->index+1 >= contextPtr->callPtr->numChain) {
+ /*
+ * We're at the end of the chain; generate an error message unless the
+ * interpreter is being torn down, in which case we might be getting
+ * here because of methods/destructors doing a [next] (or equivalent)
+ * unexpectedly.
+ */
+
+ const char *methodType;
+
+ if (Tcl_InterpDeleted(interp)) {
+ return TCL_OK;
+ }
+
+ if (contextPtr->callPtr->flags & CONSTRUCTOR) {
+ methodType = "constructor";
+ } else if (contextPtr->callPtr->flags & DESTRUCTOR) {
+ methodType = "destructor";
+ } else {
+ methodType = "method";
+ }
+
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "no next %s implementation", methodType));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Advance to the next method implementation in the chain in the method
+ * call context while we process the body. However, need to adjust the
+ * argument-skip control because we're guaranteed to have a single prefix
+ * arg (i.e., 'next') and not the variable amount that can happen because
+ * method invocations (i.e., '$obj meth' and 'my meth'), constructors
+ * (i.e., '$cls new' and '$cls create obj') and destructors (no args at
+ * all) come through the same code.
+ */
+
+ contextPtr->index++;
+ contextPtr->skip = skip;
+
+ /*
+ * Invoke the (advanced) method call context in the caller context.
+ */
+
+ result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr, objc,
+ objv);
+
+ /*
+ * Restore the call chain context index as we've finished the inner invoke
+ * and want to operate in the outer context again.
+ */
+
+ contextPtr->index = savedIndex;
+ contextPtr->skip = savedSkip;
+
+ return result;
+}
+
+int
+TclNRObjectContextInvokeNext(
+ Tcl_Interp *interp,
+ Tcl_ObjectContext context,
+ int objc,
+ Tcl_Obj *const *objv,
+ int skip)
+{
+ register CallContext *contextPtr = (CallContext *) context;
+
+ if (contextPtr->index+1 >= contextPtr->callPtr->numChain) {
+ /*
+ * We're at the end of the chain; generate an error message unless the
+ * interpreter is being torn down, in which case we might be getting
+ * here because of methods/destructors doing a [next] (or equivalent)
+ * unexpectedly.
+ */
+
+ const char *methodType;
+
+ if (Tcl_InterpDeleted(interp)) {
+ return TCL_OK;
+ }
+
+ if (contextPtr->callPtr->flags & CONSTRUCTOR) {
+ methodType = "constructor";
+ } else if (contextPtr->callPtr->flags & DESTRUCTOR) {
+ methodType = "destructor";
+ } else {
+ methodType = "method";
+ }
+
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "no next %s implementation", methodType));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Advance to the next method implementation in the chain in the method
+ * call context while we process the body. However, need to adjust the
+ * argument-skip control because we're guaranteed to have a single prefix
+ * arg (i.e., 'next') and not the variable amount that can happen because
+ * method invocations (i.e., '$obj meth' and 'my meth'), constructors
+ * (i.e., '$cls new' and '$cls create obj') and destructors (no args at
+ * all) come through the same code.
+ */
+
+ TclNRAddCallback(interp, FinalizeNext, contextPtr,
+ INT2PTR(contextPtr->index), INT2PTR(contextPtr->skip), NULL);
+ contextPtr->index++;
+ contextPtr->skip = skip;
+
+ /*
+ * Invoke the (advanced) method call context in the caller context.
+ */
+
+ return TclOOInvokeContext(contextPtr, interp, objc, objv);
+}
+
+static int
+FinalizeNext(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ CallContext *contextPtr = data[0];
+
+ /*
+ * Restore the call chain context index as we've finished the inner invoke
+ * and want to operate in the outer context again.
+ */
+
+ contextPtr->index = PTR2INT(data[1]);
+ contextPtr->skip = PTR2INT(data[2]);
+ return result;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Tcl_GetObjectFromObj --
+ *
+ * Utility function to get an object from a Tcl_Obj containing its name.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Tcl_Object
+Tcl_GetObjectFromObj(
+ Tcl_Interp *interp, /* Interpreter in which to locate the object.
+ * Will have an error message placed in it if
+ * the name does not refer to an object. */
+ Tcl_Obj *objPtr) /* The name of the object to look up, which is
+ * exactly the name of its public command. */
+{
+ Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objPtr);
+
+ if (cmdPtr == NULL) {
+ goto notAnObject;
+ }
+ if (cmdPtr->objProc != PublicObjectCmd) {
+ cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
+ if (cmdPtr == NULL || cmdPtr->objProc != PublicObjectCmd) {
+ goto notAnObject;
+ }
+ }
+ return cmdPtr->objClientData;
+
+ notAnObject:
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "%s does not refer to an object", TclGetString(objPtr)));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "OBJECT", TclGetString(objPtr),
+ NULL);
+ return NULL;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOIsReachable --
+ *
+ * Utility function that tests whether a class is a subclass (whether
+ * directly or indirectly) of another class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOOIsReachable(
+ Class *targetPtr,
+ Class *startPtr)
+{
+ int i;
+ Class *superPtr;
+
+ tailRecurse:
+ if (startPtr == targetPtr) {
+ return 1;
+ }
+ if (startPtr->superclasses.num == 1 && startPtr->mixins.num == 0) {
+ startPtr = startPtr->superclasses.list[0];
+ goto tailRecurse;
+ }
+ FOREACH(superPtr, startPtr->superclasses) {
+ if (TclOOIsReachable(targetPtr, superPtr)) {
+ return 1;
+ }
+ }
+ FOREACH(superPtr, startPtr->mixins) {
+ if (TclOOIsReachable(targetPtr, superPtr)) {
+ return 1;
+ }
+ }
+ return 0;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOObjectName, Tcl_GetObjectName --
+ *
+ * Utility function that returns the name of the object. Note that this
+ * simplifies cache management by keeping the code to do it in one place
+ * and not sprayed all over. The value returned always has a reference
+ * count of at least one.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclOOObjectName(
+ Tcl_Interp *interp,
+ Object *oPtr)
+{
+ Tcl_Obj *namePtr;
+
+ if (oPtr->cachedNameObj) {
+ return oPtr->cachedNameObj;
+ }
+ namePtr = Tcl_NewObj();
+ Tcl_GetCommandFullName(interp, oPtr->command, namePtr);
+ Tcl_IncrRefCount(namePtr);
+ oPtr->cachedNameObj = namePtr;
+ return namePtr;
+}
+
+Tcl_Obj *
+Tcl_GetObjectName(
+ Tcl_Interp *interp,
+ Tcl_Object object)
+{
+ return TclOOObjectName(interp, (Object *) object);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * assorted trivial 'getter' functions
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Tcl_Method
+Tcl_ObjectContextMethod(
+ Tcl_ObjectContext context)
+{
+ CallContext *contextPtr = (CallContext *) context;
+ return (Tcl_Method) contextPtr->callPtr->chain[contextPtr->index].mPtr;
+}
+
+int
+Tcl_ObjectContextIsFiltering(
+ Tcl_ObjectContext context)
+{
+ CallContext *contextPtr = (CallContext *) context;
+ return contextPtr->callPtr->chain[contextPtr->index].isFilter;
+}
+
+Tcl_Object
+Tcl_ObjectContextObject(
+ Tcl_ObjectContext context)
+{
+ return (Tcl_Object) ((CallContext *)context)->oPtr;
+}
+
+int
+Tcl_ObjectContextSkippedArgs(
+ Tcl_ObjectContext context)
+{
+ return ((CallContext *)context)->skip;
+}
+
+Tcl_Namespace *
+Tcl_GetObjectNamespace(
+ Tcl_Object object)
+{
+ return ((Object *)object)->namespacePtr;
+}
+
+Tcl_Command
+Tcl_GetObjectCommand(
+ Tcl_Object object)
+{
+ return ((Object *)object)->command;
+}
+
+Tcl_Class
+Tcl_GetObjectAsClass(
+ Tcl_Object object)
+{
+ return (Tcl_Class) ((Object *)object)->classPtr;
+}
+
+int
+Tcl_ObjectDeleted(
+ Tcl_Object object)
+{
+ return Deleted(object) ? 1 : 0;
+}
+
+Tcl_Object
+Tcl_GetClassAsObject(
+ Tcl_Class clazz)
+{
+ return (Tcl_Object) ((Class *)clazz)->thisPtr;
+}
+
+Tcl_ObjectMapMethodNameProc *
+Tcl_ObjectGetMethodNameMapper(
+ Tcl_Object object)
+{
+ return ((Object *) object)->mapMethodNameProc;
+}
+
+void
+Tcl_ObjectSetMethodNameMapper(
+ Tcl_Object object,
+ Tcl_ObjectMapMethodNameProc *mapMethodNameProc)
+{
+ ((Object *) object)->mapMethodNameProc = mapMethodNameProc;
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 28b6033..dc58cb0 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -124,8 +124,8 @@ Tcl_ProcObjCmd(
{
register Interp *iPtr = (Interp *) interp;
Proc *procPtr;
- const char *fullName;
- const char *procName, *procArgs, *procBody;
+ const char *procName;
+ const char *simpleName, *procArgs, *procBody;
Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
Tcl_Command cmd;
@@ -140,21 +140,21 @@ Tcl_ProcObjCmd(
* namespace.
*/
- fullName = TclGetString(objv[1]);
- TclGetNamespaceForQualName(interp, fullName, NULL, 0,
- &nsPtr, &altNsPtr, &cxtNsPtr, &procName);
+ procName = TclGetString(objv[1]);
+ TclGetNamespaceForQualName(interp, procName, NULL, 0,
+ &nsPtr, &altNsPtr, &cxtNsPtr, &simpleName);
if (nsPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create procedure \"%s\": unknown namespace",
- fullName));
+ procName));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL);
return TCL_ERROR;
}
- if (procName == NULL) {
+ if (simpleName == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create procedure \"%s\": bad procedure name",
- fullName));
+ procName));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL);
return TCL_ERROR;
}
@@ -163,15 +163,15 @@ Tcl_ProcObjCmd(
* Create the data structure to represent the procedure.
*/
- if (TclCreateProc(interp, nsPtr, procName, objv[2], objv[3],
+ if (TclCreateProc(interp, nsPtr, simpleName, objv[2], objv[3],
&procPtr) != TCL_OK) {
Tcl_AddErrorInfo(interp, "\n (creating proc \"");
- Tcl_AddErrorInfo(interp, procName);
+ Tcl_AddErrorInfo(interp, simpleName);
Tcl_AddErrorInfo(interp, "\")");
return TCL_ERROR;
}
- cmd = tclNRCreateCommandInNs(interp, procName, (Tcl_Namespace *) nsPtr,
+ cmd = TclNRCreateCommandInNs(interp, simpleName, (Tcl_Namespace *) nsPtr,
TclObjInterpProc, TclNRInterpProc, procPtr, TclProcDeleteProc);
/*
diff --git a/tests/namespace.test b/tests/namespace.test
new file mode 100644
index 0000000..1d26512
--- /dev/null
+++ b/tests/namespace.test
@@ -0,0 +1,3338 @@
+# Functionality covered: this file contains a collection of tests for the
+# procedures in tclNamesp.c and tclEnsemble.c that implement Tcl's basic
+# support for namespaces. Other namespace-related tests appear in
+# variable.test.
+#
+# Sourcing this file into Tcl runs the tests and generates output for errors.
+# No output means no errors were found.
+#
+# Copyright (c) 1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-2000 by Scriptics Corporation.
+#
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+package require tcltest 2
+namespace import -force ::tcltest::*
+testConstraint memory [llength [info commands memory]]
+
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
+#
+# REMARK: the tests for 'namespace upvar' are not done here. They are to be
+# found in the file 'upvar.test'.
+#
+
+# Clear out any namespaces called test_ns_*
+catch {namespace delete {*}[namespace children :: test_ns_*]}
+
+proc fq {ns} {
+ if {[string match ::* $ns]} {return $ns}
+ set current [uplevel 1 {namespace current}]
+ return [string trimright $current :]::[string trimleft $ns :]
+}
+
+test namespace-1.1 {TclInitNamespaces, GetNamespaceFromObj, NamespaceChildrenCmd} {
+ namespace children :: test_ns_*
+} {}
+
+catch {unset l}
+test namespace-2.1 {Tcl_GetCurrentNamespace} {
+ list [namespace current] [namespace eval {} {namespace current}] \
+ [namespace eval {} {namespace current}]
+} {:: :: ::}
+test namespace-2.2 {Tcl_GetCurrentNamespace} {
+ set l {}
+ lappend l [namespace current]
+ namespace eval test_ns_1 {
+ lappend l [namespace current]
+ namespace eval foo {
+ lappend l [namespace current]
+ }
+ }
+ lappend l [namespace current]
+} {:: ::test_ns_1 ::test_ns_1::foo ::}
+
+test namespace-3.1 {Tcl_GetGlobalNamespace} {
+ namespace eval test_ns_1 {namespace eval foo {namespace eval bar {} } }
+ # namespace children uses Tcl_GetGlobalNamespace
+ namespace eval test_ns_1 {namespace children foo b*}
+} {::test_ns_1::foo::bar}
+
+test namespace-4.1 {Tcl_PushCallFrame with isProcCallFrame=1} {
+ namespace eval test_ns_1 {
+ variable v 123
+ proc p {} {
+ variable v
+ return $v
+ }
+ }
+ test_ns_1::p ;# does Tcl_PushCallFrame to push p's namespace
+} {123}
+test namespace-4.2 {Tcl_PushCallFrame with isProcCallFrame=0} {
+ namespace eval test_ns_1::baz {} ;# does Tcl_PushCallFrame to create baz
+ proc test_ns_1::baz::p {} {
+ variable v
+ set v 789
+ set v}
+ test_ns_1::baz::p
+} {789}
+
+test namespace-5.1 {Tcl_PopCallFrame, no vars} {
+ namespace eval test_ns_1::blodge {} ;# pushes then pops frame
+} {}
+test namespace-5.2 {Tcl_PopCallFrame, local vars must be deleted} -setup {
+ namespace eval test_ns_1 {}
+} -body {
+ proc test_ns_1::r {} {
+ set a 123
+ }
+ test_ns_1::r ;# pushes then pop's r's frame
+} -result {123}
+
+test namespace-6.1 {Tcl_CreateNamespace} {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+ list [lsort [namespace children :: test_ns_*]] \
+ [namespace eval test_ns_1 {namespace current}] \
+ [namespace eval test_ns_2 {namespace current}] \
+ [namespace eval ::test_ns_3 {namespace current}] \
+ [namespace eval ::test_ns_4 \
+ {namespace eval foo {namespace current}}] \
+ [namespace eval ::test_ns_5 \
+ {namespace eval ::test_ns_6 {namespace current}}] \
+ [lsort [namespace children :: test_ns_*]]
+} {{} ::test_ns_1 ::test_ns_2 ::test_ns_3 ::test_ns_4::foo ::test_ns_6 {::test_ns_1 ::test_ns_2 ::test_ns_3 ::test_ns_4 ::test_ns_5 ::test_ns_6}}
+test namespace-6.2 {Tcl_CreateNamespace, odd number of :'s in name is okay} {
+ list [namespace eval :::test_ns_1::::foo {namespace current}] \
+ [namespace eval test_ns_2:::::foo {namespace current}]
+} {::test_ns_1::foo ::test_ns_2::foo}
+test namespace-6.3 {Tcl_CreateNamespace, trailing ::s in ns name are ignored} {
+ list [catch {namespace eval test_ns_7::: {namespace current}} msg] $msg
+} {0 ::test_ns_7}
+test namespace-6.4 {Tcl_CreateNamespace, trailing ::s in ns name are ignored} {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+ namespace eval test_ns_1:: {
+ namespace eval test_ns_2:: {}
+ namespace eval test_ns_3:: {}
+ }
+ lsort [namespace children ::test_ns_1]
+} [lsort {::test_ns_1::test_ns_2 ::test_ns_1::test_ns_3}]
+test namespace-6.5 {Tcl_CreateNamespace, relative ns names now only looked up in current ns} {
+ set trigger {
+ namespace eval test_ns_2 {namespace current}
+ }
+ set l {}
+ lappend l [namespace eval test_ns_1 $trigger]
+ namespace eval test_ns_1::test_ns_2 {}
+ lappend l [namespace eval test_ns_1 $trigger]
+} {::test_ns_1::test_ns_2 ::test_ns_1::test_ns_2}
+
+test namespace-7.1 {Tcl_DeleteNamespace, active call frames in ns} {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+ namespace eval test_ns_1 {
+ proc p {} {
+ namespace delete [namespace current]
+ return [namespace current]
+ }
+ }
+ list [test_ns_1::p] [catch {test_ns_1::p} msg] $msg
+} {::test_ns_1 1 {invalid command name "test_ns_1::p"}}
+test namespace-7.2 {Tcl_DeleteNamespace, no active call frames in ns} {
+ namespace eval test_ns_2 {
+ proc p {} {
+ return [namespace current]
+ }
+ }
+ list [test_ns_2::p] [namespace delete test_ns_2]
+} {::test_ns_2 {}}
+test namespace-7.3 {recursive Tcl_DeleteNamespace, active call frames in ns} {
+ # [Bug 1355942]
+ namespace eval test_ns_2 {
+ set x 1
+ trace add variable x unset "namespace delete [namespace current];#"
+ namespace delete [namespace current]
+ }
+} {}
+test namespace-7.4 {recursive Tcl_DeleteNamespace, active call frames in ns} {
+ # [Bug 1355942]
+ namespace eval test_ns_2 {
+ proc x {} {}
+ trace add command x delete "namespace delete [namespace current];#"
+ namespace delete [namespace current]
+ }
+} {}
+test namespace-7.5 {recursive Tcl_DeleteNamespace, no active call frames in ns} {
+ # [Bug 1355942]
+ namespace eval test_ns_2 {
+ set x 1
+ trace add variable x unset "namespace delete [namespace current];#"
+ }
+ namespace delete test_ns_2
+} {}
+test namespace-7.6 {recursive Tcl_DeleteNamespace, no active call frames in ns} {
+ # [Bug 1355942]
+ namespace eval test_ns_2 {
+ proc x {} {}
+ trace add command x delete "namespace delete [namespace current];#"
+ }
+ namespace delete test_ns_2
+} {}
+test namespace-7.7 {Bug 1655305} -setup {
+ interp create slave
+ # Can't invoke through the ensemble, since deleting the global namespace
+ # (indirectly, via deleting ::tcl) deletes the ensemble.
+ slave eval {rename ::tcl::info::commands ::infocommands}
+ slave hide infocommands
+ slave eval {
+ proc foo {} {
+ namespace delete ::
+ }
+ }
+} -body {
+ slave eval foo
+ slave invokehidden infocommands
+} -cleanup {
+ interp delete slave
+} -result {}
+
+test namespace-7.8 {Bug ba1419303b4c} -setup {
+ namespace eval ns1 {
+ namespace ensemble create
+ }
+
+ trace add command ns1 delete {
+ namespace delete ns1
+ }
+} -body {
+ # No segmentation fault given --enable-symbols=mem.
+ namespace delete ns1
+} -result {}
+
+test namespace-8.1 {TclTeardownNamespace, delete global namespace} {
+ catch {interp delete test_interp}
+ interp create test_interp
+ interp eval test_interp {
+ namespace eval test_ns_1 {
+ namespace export p
+ proc p {} {
+ return [namespace current]
+ }
+ }
+ namespace eval test_ns_2 {
+ namespace import ::test_ns_1::p
+ variable v 27
+ proc q {} {
+ variable v
+ return "[p] $v"
+ }
+ }
+ set x [test_ns_2::q]
+ catch {set xxxx}
+ }
+ list [interp eval test_interp {test_ns_2::q}] \
+ [interp eval test_interp {namespace delete ::}] \
+ [catch {interp eval test_interp {set a 123}} msg] $msg \
+ [interp delete test_interp]
+} {{::test_ns_1 27} {} 1 {invalid command name "set"} {}}
+test namespace-8.2 {TclTeardownNamespace, remove deleted ns from parent} {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+ namespace eval test_ns_1::test_ns_2::test_ns_3a {proc p {} {}}
+ namespace eval test_ns_1::test_ns_2::test_ns_3b {proc q {} {}}
+ list [namespace children test_ns_1] \
+ [namespace delete test_ns_1::test_ns_2] \
+ [namespace children test_ns_1]
+} {::test_ns_1::test_ns_2 {} {}}
+test namespace-8.3 {TclTeardownNamespace, delete child namespaces} {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+ namespace eval test_ns_1::test_ns_2::test_ns_3a {proc p {} {}}
+ namespace eval test_ns_1::test_ns_2::test_ns_3b {proc q {} {}}
+ list [namespace children test_ns_1] \
+ [namespace delete test_ns_1::test_ns_2] \
+ [namespace children test_ns_1] \
+ [catch {namespace children test_ns_1::test_ns_2} msg] $msg \
+ [info commands test_ns_1::test_ns_2::test_ns_3a::*]
+} {::test_ns_1::test_ns_2 {} {} 1 {namespace "test_ns_1::test_ns_2" not found in "::"} {}}
+test namespace-8.4 {TclTeardownNamespace, cmds imported from deleted ns go away} {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+ namespace eval test_ns_export {
+ namespace export cmd1 cmd2
+ proc cmd1 {args} {return "cmd1: $args"}
+ proc cmd2 {args} {return "cmd2: $args"}
+ }
+ namespace eval test_ns_import {
+ namespace import ::test_ns_export::*
+ proc p {} {return foo}
+ }
+ list [lsort [info commands test_ns_import::*]] \
+ [namespace delete test_ns_export] \
+ [info commands test_ns_import::*]
+} [list [lsort {::test_ns_import::p ::test_ns_import::cmd1 ::test_ns_import::cmd2}] {} ::test_ns_import::p]
+test namespace-8.5 {TclTeardownNamespace: preserve errorInfo; errorCode values} {
+ interp create slave
+ slave eval {trace add execution error leave {namespace delete :: ;#}}
+ catch {slave eval error foo bar baz}
+ interp delete slave
+ set ::errorInfo
+} {bar
+ invoked from within
+"slave eval error foo bar baz"}
+test namespace-8.6 {TclTeardownNamespace: preserve errorInfo; errorCode values} {
+ interp create slave
+ slave eval {trace add variable errorCode write {namespace delete :: ;#}}
+ catch {slave eval error foo bar baz}
+ interp delete slave
+ set ::errorInfo
+} {bar
+ invoked from within
+"slave eval error foo bar baz"}
+test namespace-8.7 {TclTeardownNamespace: preserve errorInfo; errorCode values} {
+ interp create slave
+ slave eval {trace add execution error leave {namespace delete :: ;#}}
+ catch {slave eval error foo bar baz}
+ interp delete slave
+ set ::errorCode
+} baz
+
+test namespace-9.1 {Tcl_Import, empty import pattern} {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+ list [catch {namespace eval test_ns_import {namespace import {}}} msg] $msg
+} {1 {empty import pattern}}
+test namespace-9.2 {Tcl_Import, unknown namespace in import pattern} {
+ list [catch {namespace eval test_ns_import {namespace import fred::x}} msg] $msg
+} {1 {unknown namespace in import pattern "fred::x"}}
+test namespace-9.3 {Tcl_Import, import ns == export ns} {
+ list [catch {namespace eval test_ns_import {namespace import ::test_ns_import::puts}} msg] $msg
+} {1 {import pattern "::test_ns_import::puts" tries to import from namespace "test_ns_import" into itself}}
+test namespace-9.4 {Tcl_Import, simple import} {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+ namespace eval test_ns_export {
+ namespace export cmd1
+ proc cmd1 {args} {return "cmd1: $args"}
+ proc cmd2 {args} {return "cmd2: $args"}
+ }
+ namespace eval test_ns_import {
+ namespace import ::test_ns_export::*
+ proc p {} {return [cmd1 123]}
+ }
+ test_ns_import::p
+} {cmd1: 123}
+test namespace-9.5 {Tcl_Import, RFE 1230597} -setup {
+ namespace eval test_ns_import {}
+ namespace eval test_ns_export {}
+} -body {
+ list [catch {namespace eval test_ns_import {namespace import ::test_ns_export::*}} msg] $msg
+} -result {0 {}}
+test namespace-9.6 {Tcl_Import, cmd redefinition ok if allowOverwrite!=0} -setup {
+ namespace eval test_ns_import {}
+ namespace eval ::test_ns_export {
+ proc cmd1 {args} {return "cmd1: $args"}
+ namespace export cmd1
+ }
+} -body {
+ namespace eval test_ns_import {
+ namespace import -force ::test_ns_export::*
+ cmd1 555
+ }
+} -result {cmd1: 555}
+test namespace-9.7 {Tcl_Import, links are preserved if cmd is redefined} {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+ namespace eval test_ns_export {
+ namespace export cmd1
+ proc cmd1 {args} {return "cmd1: $args"}
+ }
+ namespace eval test_ns_import {
+ namespace import -force ::test_ns_export::*
+ }
+ list [test_ns_import::cmd1 a b c] \
+ [test_ns_export::cmd1 d e f] \
+ [proc test_ns_export::cmd1 {args} {return "new1: $args"}] \
+ [namespace origin test_ns_import::cmd1] \
+ [namespace origin test_ns_export::cmd1] \
+ [test_ns_import::cmd1 g h i] \
+ [test_ns_export::cmd1 j k l]
+} {{cmd1: a b c} {cmd1: d e f} {} ::test_ns_export::cmd1 ::test_ns_export::cmd1 {new1: g h i} {new1: j k l}}
+test namespace-9.8 {Tcl_Import: Bug 1017299} -setup {
+ namespace eval one {
+ namespace export cmd
+ proc cmd {} {}
+ }
+ namespace eval two {
+ namespace export cmd
+ proc other args {}
+ }
+ namespace eval two \
+ [list namespace import [namespace current]::one::cmd]
+ namespace eval three \
+ [list namespace import [namespace current]::two::cmd]
+ namespace eval three {
+ rename cmd other
+ namespace export other
+ }
+} -body {
+ namespace eval two [list namespace import -force \
+ [namespace current]::three::other]
+ namespace origin two::other
+} -cleanup {
+ namespace delete one two three
+} -match glob -result *::one::cmd
+test namespace-9.9 {Tcl_Import: Bug 1017299} -setup {
+ namespace eval one {
+ namespace export cmd
+ proc cmd {} {}
+ }
+ namespace eval two namespace export cmd
+ namespace eval two \
+ [list namespace import [namespace current]::one::cmd]
+ namespace eval three namespace export cmd
+ namespace eval three \
+ [list namespace import [namespace current]::two::cmd]
+} -body {
+ namespace eval two [list namespace import -force \
+ [namespace current]::three::cmd]
+ namespace origin two::cmd
+} -cleanup {
+ namespace delete one two three
+} -returnCodes error -match glob -result {import pattern * would create a loop*}
+
+test namespace-10.1 {Tcl_ForgetImport, check for valid namespaces} {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+ list [catch {namespace forget xyzzy::*} msg] $msg
+} {1 {unknown namespace in namespace forget pattern "xyzzy::*"}}
+test namespace-10.2 {Tcl_ForgetImport, ignores patterns that don't match} {
+ namespace eval test_ns_export {
+ namespace export cmd1
+ proc cmd1 {args} {return "cmd1: $args"}
+ proc cmd2 {args} {return "cmd2: $args"}
+ }
+ namespace eval test_ns_import {
+ namespace forget ::test_ns_export::wombat
+ }
+} {}
+test namespace-10.3 {Tcl_ForgetImport, deletes matching imported cmds} -setup {
+ namespace eval test_ns_export {
+ namespace export cmd1
+ proc cmd1 {args} {return "cmd1: $args"}
+ proc cmd2 {args} {return "cmd2: $args"}
+ }
+} -body {
+ namespace eval test_ns_import {
+ namespace import ::test_ns_export::*
+ proc p {} {return [cmd1 123]}
+ set l {}
+ lappend l [lsort [info commands ::test_ns_import::*]]
+ namespace forget ::test_ns_export::cmd1
+ lappend l [info commands ::test_ns_import::*]
+ lappend l [catch {cmd1 777} msg] $msg
+ }
+} -result [list [lsort {::test_ns_import::p ::test_ns_import::cmd1}] ::test_ns_import::p 1 {invalid command name "cmd1"}]
+test namespace-10.4 {Tcl_ForgetImport: Bug 560297} -setup {
+ namespace eval origin {
+ namespace export cmd
+ proc cmd {} {}
+ }
+ namespace eval unrelated {
+ proc cmd {} {}
+ }
+ namespace eval my \
+ [list namespace import [namespace current]::origin::cmd]
+} -body {
+ namespace eval my \
+ [list namespace forget [namespace current]::unrelated::cmd]
+ my::cmd
+} -cleanup {
+ namespace delete origin unrelated my
+}
+test namespace-10.5 {Tcl_ForgetImport: Bug 560297} -setup {
+ namespace eval origin {
+ namespace export cmd
+ proc cmd {} {}
+ }
+ namespace eval my \
+ [list namespace import [namespace current]::origin::cmd]
+ namespace eval my rename cmd newname
+} -body {
+ namespace eval my \
+ [list namespace forget [namespace current]::origin::cmd]
+ my::newname
+} -cleanup {
+ namespace delete origin my
+} -returnCodes error -match glob -result *
+test namespace-10.6 {Tcl_ForgetImport: Bug 560297} -setup {
+ namespace eval origin {
+ namespace export cmd
+ proc cmd {} {}
+ }
+ namespace eval my \
+ [list namespace import [namespace current]::origin::cmd]
+ namespace eval your {}
+ namespace eval my \
+ [list rename cmd [namespace current]::your::newname]
+} -body {
+ namespace eval your namespace forget newname
+ your::newname
+} -cleanup {
+ namespace delete origin my your
+} -returnCodes error -match glob -result *
+test namespace-10.7 {Tcl_ForgetImport: Bug 560297} -setup {
+ namespace eval origin {
+ namespace export cmd
+ proc cmd {} {}
+ }
+ namespace eval link namespace export cmd
+ namespace eval link \
+ [list namespace import [namespace current]::origin::cmd]
+ namespace eval link2 namespace export cmd
+ namespace eval link2 \
+ [list namespace import [namespace current]::link::cmd]
+ namespace eval my \
+ [list namespace import [namespace current]::link2::cmd]
+} -body {
+ namespace eval my \
+ [list namespace forget [namespace current]::origin::cmd]
+ my::cmd
+} -cleanup {
+ namespace delete origin link link2 my
+} -returnCodes error -match glob -result *
+test namespace-10.8 {Tcl_ForgetImport: Bug 560297} -setup {
+ namespace eval origin {
+ namespace export cmd
+ proc cmd {} {}
+ }
+ namespace eval link namespace export cmd
+ namespace eval link \
+ [list namespace import [namespace current]::origin::cmd]
+ namespace eval link2 namespace export cmd
+ namespace eval link2 \
+ [list namespace import [namespace current]::link::cmd]
+ namespace eval my \
+ [list namespace import [namespace current]::link2::cmd]
+} -body {
+ namespace eval my \
+ [list namespace forget [namespace current]::link::cmd]
+ my::cmd
+} -cleanup {
+ namespace delete origin link link2 my
+}
+test namespace-10.9 {Tcl_ForgetImport: Bug 560297} -setup {
+ namespace eval origin {
+ namespace export cmd
+ proc cmd {} {}
+ }
+ namespace eval link namespace export cmd
+ namespace eval link \
+ [list namespace import [namespace current]::origin::cmd]
+ namespace eval link2 namespace export cmd
+ namespace eval link2 \
+ [list namespace import [namespace current]::link::cmd]
+ namespace eval my \
+ [list namespace import [namespace current]::link2::cmd]
+} -body {
+ namespace eval my \
+ [list namespace forget [namespace current]::link2::cmd]
+ my::cmd
+} -cleanup {
+ namespace delete origin link link2 my
+} -returnCodes error -match glob -result *
+
+test namespace-11.1 {TclGetOriginalCommand, check if not imported cmd} -setup {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+} -body {
+ namespace eval test_ns_export {
+ namespace export cmd1
+ proc cmd1 {args} {return "cmd1: $args"}
+ }
+ list [namespace origin set] [namespace origin test_ns_export::cmd1]
+} -result {::set ::test_ns_export::cmd1}
+test namespace-11.2 {TclGetOriginalCommand, directly imported cmd} -setup {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+ namespace eval test_ns_export {
+ namespace export cmd1
+ proc cmd1 {args} {return "cmd1: $args"}
+ }
+} -body {
+ namespace eval test_ns_import1 {
+ namespace import ::test_ns_export::*
+ namespace export *
+ proc p {} {namespace origin cmd1}
+ }
+ list [test_ns_import1::p] [namespace origin test_ns_import1::cmd1]
+} -result {::test_ns_export::cmd1 ::test_ns_export::cmd1}
+test namespace-11.3 {TclGetOriginalCommand, indirectly imported cmd} -setup {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+ namespace eval test_ns_export {
+ namespace export cmd1
+ proc cmd1 {args} {return "cmd1: $args"}
+ }
+ namespace eval test_ns_import1 {
+ namespace import ::test_ns_export::*
+ namespace export *
+ proc p {} {namespace origin cmd1}
+ }
+} -body {
+ namespace eval test_ns_import2 {
+ namespace import ::test_ns_import1::*
+ proc q {} {return [cmd1 123]}
+ }
+ list [test_ns_import2::q] [namespace origin test_ns_import2::cmd1]
+} -result {{cmd1: 123} ::test_ns_export::cmd1}
+
+test namespace-12.1 {InvokeImportedCmd} {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+ namespace eval test_ns_export {
+ namespace export cmd1
+ proc cmd1 {args} {namespace current}
+ }
+ namespace eval test_ns_import {
+ namespace import ::test_ns_export::*
+ }
+ list [test_ns_import::cmd1]
+} {::test_ns_export}
+
+test namespace-13.1 {DeleteImportedCmd, deletes imported cmds} -setup {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+ namespace eval test_ns_export {
+ namespace export cmd1
+ proc cmd1 {args} {namespace current}
+ }
+ namespace eval test_ns_import {
+ namespace import ::test_ns_export::*
+ }
+} -body {
+ namespace eval test_ns_import {
+ set l {}
+ lappend l [info commands ::test_ns_import::*]
+ namespace forget ::test_ns_export::cmd1
+ lappend l [info commands ::test_ns_import::*]
+ }
+} -result {::test_ns_import::cmd1 {}}
+test namespace-13.2 {DeleteImportedCmd, Bug a4494e28ed} {
+ # Will panic if still buggy
+ namespace eval src {namespace export foo; proc foo {} {}}
+ namespace eval dst {namespace import [namespace parent]::src::foo}
+ trace add command src::foo delete \
+ "[list namespace delete [namespace current]::dst] ;#"
+ proc src::foo {} {}
+ namespace delete src
+} {}
+
+test namespace-14.1 {TclGetNamespaceForQualName, absolute names} -setup {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+ variable v 10
+ namespace eval test_ns_1::test_ns_2 {
+ variable v 20
+ }
+ namespace eval test_ns_2 {
+ variable v 30
+ }
+} -body {
+ namespace eval test_ns_1 {
+ list $::v $::test_ns_2::v $::test_ns_1::test_ns_2::v \
+ [lsort [namespace children :: test_ns_*]]
+ }
+} -result [list 10 30 20 [lsort {::test_ns_1 ::test_ns_2}]]
+test namespace-14.2 {TclGetNamespaceForQualName, invalid absolute names} -setup {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+ variable v 10
+ namespace eval test_ns_1::test_ns_2 {
+ variable v 20
+ }
+ namespace eval test_ns_2 {
+ variable v 30
+ }
+} -body {
+ namespace eval test_ns_1 {
+ list [catch {set ::test_ns_777::v} msg] $msg \
+ [catch {namespace children test_ns_777} msg] $msg
+ }
+} -result {1 {can't read "::test_ns_777::v": no such variable} 1 {namespace "test_ns_777" not found in "::test_ns_1"}}
+test namespace-14.3 {TclGetNamespaceForQualName, relative names} -setup {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+ variable v 10
+ namespace eval test_ns_1::test_ns_2 {
+ variable v 20
+ }
+ namespace eval test_ns_2 {
+ variable v 30
+ }
+} -body {
+ namespace eval test_ns_1 {
+ list $v $test_ns_2::v
+ }
+} -result {10 20}
+test namespace-14.4 {TclGetNamespaceForQualName, relative ns names looked up only in current ns} {
+ namespace eval test_ns_1::test_ns_2 {
+ namespace eval foo {}
+ }
+ namespace eval test_ns_1 {
+ list [namespace children test_ns_2] \
+ [catch {namespace children test_ns_1} msg] $msg
+ }
+} {::test_ns_1::test_ns_2::foo 1 {namespace "test_ns_1" not found in "::test_ns_1"}}
+test namespace-14.5 {TclGetNamespaceForQualName, relative ns names looked up only in current ns} {
+ namespace eval ::test_ns_2 {
+ namespace eval bar {}
+ }
+ namespace eval test_ns_1 {
+ list [catch {namespace delete test_ns_2::bar} msg] $msg
+ }
+} {1 {unknown namespace "test_ns_2::bar" in namespace delete command}}
+test namespace-14.6 {TclGetNamespaceForQualName, relative ns names looked up only in current ns} {
+ namespace eval test_ns_1::test_ns_2 {
+ namespace eval foo {}
+ }
+ namespace eval test_ns_1 {
+ list [namespace children test_ns_2] \
+ [catch {namespace children test_ns_1} msg] $msg
+ }
+} {::test_ns_1::test_ns_2::foo 1 {namespace "test_ns_1" not found in "::test_ns_1"}}
+test namespace-14.7 {TclGetNamespaceForQualName, ignore extra :s if ns} -setup {
+ namespace eval test_ns_1::test_ns_2::foo {}
+} -body {
+ namespace children test_ns_1:::
+} -result {::test_ns_1::test_ns_2}
+test namespace-14.8 {TclGetNamespaceForQualName, ignore extra :s if ns} -setup {
+ namespace eval test_ns_1::test_ns_2::foo {}
+} -body {
+ namespace children :::test_ns_1:::::test_ns_2:::
+} -result {::test_ns_1::test_ns_2::foo}
+test namespace-14.9 {TclGetNamespaceForQualName, extra ::s are significant for vars} {
+ set l {}
+ lappend l [catch {set test_ns_1::test_ns_2::} msg] $msg
+ namespace eval test_ns_1::test_ns_2 {variable {} 2525}
+ lappend l [set test_ns_1::test_ns_2::]
+} {1 {can't read "test_ns_1::test_ns_2::": no such variable} 2525}
+test namespace-14.10 {TclGetNamespaceForQualName, extra ::s are significant for vars} -setup {
+ namespace eval test_ns_1::test_ns_2::foo {}
+ unset -nocomplain test_ns_1::test_ns_2::
+ set l {}
+} -body {
+ lappend l [catch {set test_ns_1::test_ns_2::} msg] $msg
+ set test_ns_1::test_ns_2:: 314159
+ lappend l [set test_ns_1::test_ns_2::]
+} -result {1 {can't read "test_ns_1::test_ns_2::": no such variable} 314159}
+test namespace-14.11 {TclGetNamespaceForQualName, extra ::s are significant for commands} -setup {
+ namespace eval test_ns_1::test_ns_2::foo {}
+ catch {rename test_ns_1::test_ns_2:: {}}
+ set l {}
+} -body {
+ lappend l [catch {test_ns_1::test_ns_2:: hello} msg] $msg
+ proc test_ns_1::test_ns_2:: {args} {return "\{\}: $args"}
+ lappend l [test_ns_1::test_ns_2:: hello]
+} -result {1 {invalid command name "test_ns_1::test_ns_2::"} {{}: hello}}
+test namespace-14.12 {TclGetNamespaceForQualName, extra ::s are significant for vars} -setup {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+} -body {
+ namespace eval test_ns_1 {
+ variable {}
+ set test_ns_1::(x) y
+ }
+ set test_ns_1::(x)
+} -result y
+test namespace-14.13 {TclGetNamespaceForQualName, namespace other than global ns can't have empty name} -setup {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+} -returnCodes error -body {
+ namespace eval test_ns_1 {
+ proc {} {} {}
+ namespace eval {} {}
+ {}
+ }
+} -result {can't create namespace "": only global namespace can have empty name}
+
+test namespace-15.1 {Tcl_FindNamespace, absolute name found} -setup {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+} -body {
+ namespace eval test_ns_delete {
+ namespace eval test_ns_delete2 {}
+ proc cmd {args} {namespace current}
+ }
+ list [namespace delete ::test_ns_delete::test_ns_delete2] \
+ [namespace children ::test_ns_delete]
+} -result {{} {}}
+test namespace-15.2 {Tcl_FindNamespace, absolute name not found} -body {
+ namespace delete ::test_ns_delete::test_ns_delete2
+} -returnCodes error -result {unknown namespace "::test_ns_delete::test_ns_delete2" in namespace delete command}
+test namespace-15.3 {Tcl_FindNamespace, relative name found} {
+ namespace eval test_ns_delete {
+ namespace eval test_ns_delete2 {}
+ namespace eval test_ns_delete3 {}
+ list [namespace delete test_ns_delete2] \
+ [namespace children [namespace current]]
+ }
+} {{} ::test_ns_delete::test_ns_delete3}
+test namespace-15.4 {Tcl_FindNamespace, relative name not found} {
+ namespace eval test_ns_delete2 {}
+ namespace eval test_ns_delete {
+ list [catch {namespace delete test_ns_delete2} msg] $msg
+ }
+} {1 {unknown namespace "test_ns_delete2" in namespace delete command}}
+
+test namespace-16.1 {Tcl_FindCommand, absolute name found} -setup {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+} -body {
+ namespace eval test_ns_1 {
+ proc cmd {args} {return "[namespace current]::cmd: $args"}
+ variable v "::test_ns_1::cmd"
+ eval $v one
+ }
+} -result {::test_ns_1::cmd: one}
+test namespace-16.2 {Tcl_FindCommand, absolute name found} -setup {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+ namespace eval test_ns_1 {
+ proc cmd {args} {return "[namespace current]::cmd: $args"}
+ variable v "::test_ns_1::cmd"
+ }
+} -body {
+ eval $test_ns_1::v two
+} -result {::test_ns_1::cmd: two}
+test namespace-16.3 {Tcl_FindCommand, absolute name not found} {
+ namespace eval test_ns_1 {
+ variable v2 "::test_ns_1::ladidah"
+ list [catch {eval $v2} msg] $msg
+ }
+} {1 {invalid command name "::test_ns_1::ladidah"}}
+
+# save the "unknown" proc, which is redefined by the following two tests
+catch {rename unknown unknown.old}
+proc unknown {args} {
+ return "unknown: $args"
+}
+test namespace-16.4 {Tcl_FindCommand, absolute name and TCL_GLOBAL_ONLY} {
+ ::test_ns_1::foobar x y z
+} {unknown: ::test_ns_1::foobar x y z}
+test namespace-16.5 {Tcl_FindCommand, absolute name and TCL_GLOBAL_ONLY} {
+ ::foobar 1 2 3 4 5
+} {unknown: ::foobar 1 2 3 4 5}
+test namespace-16.6 {Tcl_FindCommand, relative name and TCL_GLOBAL_ONLY} {
+ test_ns_1::foobar x y z
+} {unknown: test_ns_1::foobar x y z}
+test namespace-16.7 {Tcl_FindCommand, relative name and TCL_GLOBAL_ONLY} {
+ foobar 1 2 3 4 5
+} {unknown: foobar 1 2 3 4 5}
+# restore the "unknown" proc saved previously
+catch {rename unknown {}}
+catch {rename unknown.old unknown}
+
+test namespace-16.8 {Tcl_FindCommand, relative name found} -setup {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+ namespace eval test_ns_1 {
+ proc cmd {args} {return "[namespace current]::cmd: $args"}
+ }
+} -body {
+ namespace eval test_ns_1 {
+ cmd a b c
+ }
+} -result {::test_ns_1::cmd: a b c}
+test namespace-16.9 {Tcl_FindCommand, relative name found} -body {
+ proc cmd2 {args} {return "[namespace current]::cmd2: $args"}
+ namespace eval test_ns_1 {
+ cmd2 a b c
+ }
+} -cleanup {
+ catch {rename cmd2 {}}
+} -result {::::cmd2: a b c}
+test namespace-16.10 {Tcl_FindCommand, relative name found, only look in current then global ns} -body {
+ proc cmd2 {args} {return "[namespace current]::cmd2: $args"}
+ namespace eval test_ns_1 {
+ proc cmd2 {args} {
+ return "[namespace current]::cmd2 in test_ns_1: $args"
+ }
+ namespace eval test_ns_12 {
+ cmd2 a b c
+ }
+ }
+} -cleanup {
+ catch {rename cmd2 {}}
+} -result {::::cmd2: a b c}
+test namespace-16.11 {Tcl_FindCommand, relative name not found} -body {
+ namespace eval test_ns_1 {
+ cmd3 a b c
+ }
+} -returnCodes error -result {invalid command name "cmd3"}
+
+unset -nocomplain x
+test namespace-17.1 {Tcl_FindNamespaceVar, absolute name found} -setup {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+} -body {
+ set x 314159
+ namespace eval test_ns_1 {
+ set ::x
+ }
+} -result {314159}
+variable ::x 314159
+test namespace-17.2 {Tcl_FindNamespaceVar, absolute name found} {
+ namespace eval test_ns_1 {
+ variable x 777
+ set ::test_ns_1::x
+ }
+} {777}
+test namespace-17.3 {Tcl_FindNamespaceVar, absolute name found} {
+ namespace eval test_ns_1 {
+ namespace eval test_ns_2 {
+ variable x 1111
+ }
+ set ::test_ns_1::test_ns_2::x
+ }
+} {1111}
+test namespace-17.4 {Tcl_FindNamespaceVar, absolute name not found} -body {
+ namespace eval test_ns_1 {
+ namespace eval test_ns_2 {
+ variable x 1111
+ }
+ set ::test_ns_1::test_ns_2::y
+ }
+} -returnCodes error -result {can't read "::test_ns_1::test_ns_2::y": no such variable}
+test namespace-17.5 {Tcl_FindNamespaceVar, absolute name and TCL_GLOBAL_ONLY} -setup {
+ namespace eval ::test_ns_1::test_ns_2 {}
+} -body {
+ namespace eval test_ns_1 {
+ namespace eval test_ns_3 {
+ variable ::test_ns_1::test_ns_2::x 2222
+ }
+ }
+ set ::test_ns_1::test_ns_2::x
+} -result {2222}
+test namespace-17.6 {Tcl_FindNamespaceVar, relative name found} -setup {
+ namespace eval test_ns_1 {
+ variable x 777
+ }
+} -body {
+ namespace eval test_ns_1 {
+ set x
+ }
+} -result {777}
+test namespace-17.7 {Tcl_FindNamespaceVar, relative name found} {
+ namespace eval test_ns_1 {
+ variable x 777
+ unset x
+ set x ;# must be global x now
+ }
+} {314159}
+test namespace-17.8 {Tcl_FindNamespaceVar, relative name not found} -body {
+ namespace eval test_ns_1 {
+ set wuzzat
+ }
+} -returnCodes error -result {can't read "wuzzat": no such variable}
+test namespace-17.9 {Tcl_FindNamespaceVar, relative name and TCL_GLOBAL_ONLY} {
+ namespace eval test_ns_1 {
+ variable a hello
+ }
+ set test_ns_1::a
+} {hello}
+test namespace-17.10 {Tcl_FindNamespaceVar, interference with cached varNames} -setup {
+ namespace eval test_ns_1 {}
+} -body {
+ proc test_ns {} {
+ set ::test_ns_1::a 0
+ }
+ test_ns
+ rename test_ns {}
+ namespace eval test_ns_1 unset a
+ set a 0
+ namespace eval test_ns_1 set a 1
+ namespace delete test_ns_1
+ return $a
+} -result 1
+catch {unset a}
+catch {unset x}
+
+catch {unset l}
+catch {rename foo {}}
+test namespace-18.1 {TclResetShadowedCmdRefs, one-level check for command shadowing} -setup {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+} -body {
+ proc foo {} {return "global foo"}
+ namespace eval test_ns_1 {
+ proc trigger {} {
+ return [foo]
+ }
+ }
+ set l ""
+ lappend l [test_ns_1::trigger]
+ namespace eval test_ns_1 {
+ # force invalidation of cached ref to "foo" in proc trigger
+ proc foo {} {return "foo in test_ns_1"}
+ }
+ lappend l [test_ns_1::trigger]
+} -result {{global foo} {foo in test_ns_1}}
+test namespace-18.2 {TclResetShadowedCmdRefs, multilevel check for command shadowing} {
+ namespace eval test_ns_2 {
+ proc foo {} {return "foo in ::test_ns_2"}
+ }
+ namespace eval test_ns_1 {
+ namespace eval test_ns_2 {}
+ proc trigger {} {
+ return [test_ns_2::foo]
+ }
+ }
+ set l ""
+ lappend l [test_ns_1::trigger]
+ namespace eval test_ns_1 {
+ namespace eval test_ns_2 {
+ # force invalidation of cached ref to "foo" in proc trigger
+ proc foo {} {return "foo in ::test_ns_1::test_ns_2"}
+ }
+ }
+ lappend l [test_ns_1::trigger]
+} {{foo in ::test_ns_2} {foo in ::test_ns_1::test_ns_2}}
+catch {unset l}
+catch {rename foo {}}
+
+test namespace-19.1 {GetNamespaceFromObj, global name found} -setup {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+} -body {
+ namespace eval test_ns_1::test_ns_2 {}
+ namespace children ::test_ns_1
+} -result {::test_ns_1::test_ns_2}
+test namespace-19.2 {GetNamespaceFromObj, relative name found} -setup {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+ namespace eval test_ns_1::test_ns_2 {}
+} -body {
+ namespace eval test_ns_1 {
+ namespace children test_ns_2
+ }
+} -result {}
+test namespace-19.3 {GetNamespaceFromObj, name not found} -setup {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+} -body {
+ namespace eval test_ns_1 {
+ namespace children test_ns_99
+ }
+} -returnCodes error -result {namespace "test_ns_99" not found in "::test_ns_1"}
+test namespace-19.4 {GetNamespaceFromObj, invalidation of cached ns refs} -setup {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+ namespace eval test_ns_1::test_ns_2 {}
+} -body {
+ namespace eval test_ns_1 {
+ proc foo {} {
+ return [namespace children test_ns_2]
+ }
+ list [catch {namespace children test_ns_99} msg] $msg
+ }
+ set l {}
+ lappend l [test_ns_1::foo]
+ namespace delete test_ns_1::test_ns_2
+ namespace eval test_ns_1::test_ns_2::test_ns_3 {}
+ lappend l [test_ns_1::foo]
+} -result {{} ::test_ns_1::test_ns_2::test_ns_3}
+
+test namespace-20.1 {Tcl_NamespaceObjCmd, bad subcommand} {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+ list [catch {namespace} msg] $msg
+} {1 {wrong # args: should be "namespace subcommand ?arg ...?"}}
+test namespace-20.2 {Tcl_NamespaceObjCmd, bad subcommand} -body {
+ namespace wombat {}
+} -returnCodes error -match glob -result {unknown or ambiguous subcommand "wombat": must be *}
+test namespace-20.3 {Tcl_NamespaceObjCmd, abbreviations are okay} {
+ namespace ch :: test_ns_*
+} {}
+
+test namespace-21.1 {NamespaceChildrenCmd, no args} -setup {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+} -body {
+ namespace eval test_ns_1::test_ns_2 {}
+ expr {"::test_ns_1" in [namespace children]}
+} -result {1}
+test namespace-21.2 {NamespaceChildrenCmd, no args} -setup {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+ namespace eval test_ns_1::test_ns_2 {}
+} -body {
+ namespace eval test_ns_1 {
+ namespace children
+ }
+} -result {::test_ns_1::test_ns_2}
+test namespace-21.3 {NamespaceChildrenCmd, ns name given} -setup {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+ namespace eval test_ns_1::test_ns_2 {}
+} -body {
+ namespace children ::test_ns_1
+} -result {::test_ns_1::test_ns_2}
+test namespace-21.4 {NamespaceChildrenCmd, ns name given} -setup {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+ namespace eval test_ns_1::test_ns_2 {}
+} -body {
+ namespace eval test_ns_1 {
+ namespace children test_ns_2
+ }
+} -result {}
+test namespace-21.5 {NamespaceChildrenCmd, too many args} {
+ namespace eval test_ns_1 {
+ list [catch {namespace children test_ns_2 xxx yyy} msg] $msg
+ }
+} {1 {wrong # args: should be "namespace children ?name? ?pattern?"}}
+test namespace-21.6 {NamespaceChildrenCmd, glob-style pattern given} {
+ namespace eval test_ns_1::test_ns_foo {}
+ namespace children test_ns_1 *f*
+} {::test_ns_1::test_ns_foo}
+test namespace-21.7 {NamespaceChildrenCmd, glob-style pattern given} -setup {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+ namespace eval test_ns_1::test_ns_2 {}
+} -body {
+ namespace eval test_ns_1::test_ns_foo {}
+ lsort [namespace children test_ns_1 test*]
+} -result {::test_ns_1::test_ns_2 ::test_ns_1::test_ns_foo}
+test namespace-21.8 {NamespaceChildrenCmd, trivial pattern starting with ::} {
+ namespace eval test_ns_1 {}
+ namespace children [namespace current] [fq test_ns_1]
+} [fq test_ns_1]
+
+test namespace-22.1 {NamespaceCodeCmd, bad args} {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+ list [catch {namespace code} msg] $msg \
+ [catch {namespace code xxx yyy} msg] $msg
+} {1 {wrong # args: should be "namespace code arg"} 1 {wrong # args: should be "namespace code arg"}}
+test namespace-22.2 {NamespaceCodeCmd, arg is already scoped value} {
+ namespace eval test_ns_1 {
+ proc cmd {} {return "test_ns_1::cmd"}
+ }
+ namespace code {::namespace inscope ::test_ns_1 cmd}
+} {::namespace inscope ::test_ns_1 cmd}
+test namespace-22.3 {NamespaceCodeCmd, arg is already scoped value} {
+ namespace code {namespace inscope ::test_ns_1 cmd}
+} {::namespace inscope :: {namespace inscope ::test_ns_1 cmd}}
+test namespace-22.4 {NamespaceCodeCmd, in :: namespace} {
+ namespace code unknown
+} {::namespace inscope :: unknown}
+test namespace-22.5 {NamespaceCodeCmd, in other namespace} {
+ namespace eval test_ns_1 {
+ namespace code cmd
+ }
+} {::namespace inscope ::test_ns_1 cmd}
+test namespace-22.6 {NamespaceCodeCmd, in other namespace} {
+ namespace eval test_ns_1 {
+ variable v 42
+ }
+ namespace eval test_ns_2 {
+ proc namespace args {}
+ }
+ namespace eval test_ns_2 [namespace eval test_ns_1 {
+ namespace code {set v}
+ }]
+} {42}
+test namespace-22.7 {NamespaceCodeCmd, Bug 3202171} {
+ namespace eval demo {
+ proc namespace args {puts $args}
+ ::namespace code {namespace inscope foo}
+ }
+} [list ::namespace inscope [fq demo] {namespace inscope foo}]
+
+test namespace-23.1 {NamespaceCurrentCmd, bad args} {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+ list [catch {namespace current xxx} msg] $msg \
+ [catch {namespace current xxx yyy} msg] $msg
+} {1 {wrong # args: should be "namespace current"} 1 {wrong # args: should be "namespace current"}}
+test namespace-23.2 {NamespaceCurrentCmd, at global level} {
+ namespace current
+} {::}
+test namespace-23.3 {NamespaceCurrentCmd, in nested ns} {
+ namespace eval test_ns_1::test_ns_2 {
+ namespace current
+ }
+} {::test_ns_1::test_ns_2}
+
+test namespace-24.1 {NamespaceDeleteCmd, no args} {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+ namespace delete
+} {}
+test namespace-24.2 {NamespaceDeleteCmd, one arg} {
+ namespace eval test_ns_1::test_ns_2 {}
+ namespace delete ::test_ns_1
+} {}
+test namespace-24.3 {NamespaceDeleteCmd, two args} {
+ namespace eval test_ns_1::test_ns_2 {}
+ list [namespace delete ::test_ns_1::test_ns_2] [namespace delete ::test_ns_1]
+} {{} {}}
+test namespace-24.4 {NamespaceDeleteCmd, unknown ns} {
+ list [catch {namespace delete ::test_ns_foo} msg] $msg
+} {1 {unknown namespace "::test_ns_foo" in namespace delete command}}
+
+test namespace-25.1 {NamespaceEvalCmd, bad args} {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+ list [catch {namespace eval} msg] $msg
+} {1 {wrong # args: should be "namespace eval name arg ?arg...?"}}
+test namespace-25.2 {NamespaceEvalCmd, bad args} -body {
+ namespace test_ns_1
+} -returnCodes error -match glob -result {unknown or ambiguous subcommand "test_ns_1": must be *}
+catch {unset v}
+test namespace-25.3 {NamespaceEvalCmd, new namespace} {
+ set v 123
+ namespace eval test_ns_1 {
+ variable v 314159
+ proc p {} {
+ variable v
+ return $v
+ }
+ }
+ test_ns_1::p
+} {314159}
+test namespace-25.4 {NamespaceEvalCmd, existing namespace} -setup {
+ namespace eval test_ns_1 {
+ variable v 314159
+ proc p {} {
+ variable v
+ return $v
+ }
+ }
+} -body {
+ namespace eval test_ns_1 {
+ proc q {} {return [expr {[p]+1}]}
+ }
+ test_ns_1::q
+} -result {314160}
+test namespace-25.5 {NamespaceEvalCmd, multiple args} -setup {
+ namespace eval test_ns_1 {variable v 314159}
+} -body {
+ namespace eval test_ns_1 "set" "v"
+} -result {314159}
+test namespace-25.6 {NamespaceEvalCmd, error in eval'd script} {
+ list [catch {namespace eval test_ns_1 {xxxx}} msg] $msg $::errorInfo
+} {1 {invalid command name "xxxx"} {invalid command name "xxxx"
+ while executing
+"xxxx"
+ (in namespace eval "::test_ns_1" script line 1)
+ invoked from within
+"namespace eval test_ns_1 {xxxx}"}}
+test namespace-25.7 {NamespaceEvalCmd, error in eval'd script} {
+ list [catch {namespace eval test_ns_1 {error foo bar baz}} msg] $msg $::errorInfo
+} {1 foo {bar
+ (in namespace eval "::test_ns_1" script line 1)
+ invoked from within
+"namespace eval test_ns_1 {error foo bar baz}"}}
+test namespace-25.8 {NamespaceEvalCmd, error in eval'd script} {
+ list [catch {namespace eval test_ns_1 error foo bar baz} msg] $msg $::errorInfo
+} {1 foo {bar
+ (in namespace eval "::test_ns_1" script line 1)
+ invoked from within
+"namespace eval test_ns_1 error foo bar baz"}}
+catch {unset v}
+test namespace-25.9 {NamespaceEvalCmd, 545325} {
+ namespace eval test_ns_1 info level 0
+} {namespace eval test_ns_1 info level 0}
+
+test namespace-26.1 {NamespaceExportCmd, no args and new ns} {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+ namespace export
+} {}
+test namespace-26.2 {NamespaceExportCmd, just -clear arg} {
+ namespace export -clear
+} {}
+test namespace-26.3 {NamespaceExportCmd, pattern can't specify a namespace} {
+ namespace eval test_ns_1 {
+ list [catch {namespace export ::zzz} msg] $msg
+ }
+} {1 {invalid export pattern "::zzz": pattern can't specify a namespace}}
+test namespace-26.4 {NamespaceExportCmd, one pattern} {
+ namespace eval test_ns_1 {
+ namespace export cmd1
+ proc cmd1 {args} {return "cmd1: $args"}
+ proc cmd2 {args} {return "cmd2: $args"}
+ proc cmd3 {args} {return "cmd3: $args"}
+ proc cmd4 {args} {return "cmd4: $args"}
+ }
+ namespace eval test_ns_2 {
+ namespace import ::test_ns_1::*
+ }
+ list [info commands test_ns_2::*] [test_ns_2::cmd1 hello]
+} {::test_ns_2::cmd1 {cmd1: hello}}
+test namespace-26.5 {NamespaceExportCmd, sequence of patterns, patterns accumulate} -setup {
+ catch {namespace delete {*}[namespace children test_ns_*]}
+ namespace eval test_ns_1 {
+ proc cmd1 {args} {return "cmd1: $args"}
+ proc cmd2 {args} {return "cmd2: $args"}
+ proc cmd3 {args} {return "cmd3: $args"}
+ proc cmd4 {args} {return "cmd4: $args"}
+ namespace export cmd1 cmd3
+ }
+} -body {
+ namespace eval test_ns_2 {
+ namespace import -force ::test_ns_1::*
+ }
+ list [lsort [info commands test_ns_2::*]] [test_ns_2::cmd3 hello]
+} -result {{::test_ns_2::cmd1 ::test_ns_2::cmd3} {cmd3: hello}}
+test namespace-26.6 {NamespaceExportCmd, no patterns means return uniq'ed export list} -setup {
+ catch {namespace delete {*}[namespace children test_ns_*]}
+ namespace eval test_ns_1 {
+ proc cmd1 {args} {return "cmd1: $args"}
+ proc cmd2 {args} {return "cmd2: $args"}
+ proc cmd3 {args} {return "cmd3: $args"}
+ proc cmd4 {args} {return "cmd4: $args"}
+ namespace export cmd1 cmd3
+ }
+} -body {
+ namespace eval test_ns_1 {
+ namespace export
+ }
+} -result {cmd1 cmd3}
+test namespace-26.7 {NamespaceExportCmd, -clear resets export list} -setup {
+ catch {namespace delete {*}[namespace children test_ns_*]}
+ namespace eval test_ns_1 {
+ proc cmd1 {args} {return "cmd1: $args"}
+ proc cmd2 {args} {return "cmd2: $args"}
+ proc cmd3 {args} {return "cmd3: $args"}
+ proc cmd4 {args} {return "cmd4: $args"}
+ }
+} -body {
+ namespace eval test_ns_1 {
+ namespace export cmd1 cmd3
+ }
+ namespace eval test_ns_2 {
+ namespace import ::test_ns_1::*
+ }
+ namespace eval test_ns_1 {
+ namespace export -clear cmd4
+ }
+ namespace eval test_ns_2 {
+ namespace import ::test_ns_1::*
+ }
+ list [lsort [info commands test_ns_2::*]] [test_ns_2::cmd4 hello]
+} -result [list [lsort {::test_ns_2::cmd4 ::test_ns_2::cmd1 ::test_ns_2::cmd3}] {cmd4: hello}]
+test namespace-26.8 {NamespaceExportCmd, -clear resets export list} {
+ catch {namespace delete foo}
+ namespace eval foo {
+ namespace export x
+ namespace export -clear
+ }
+ list [namespace eval foo namespace export] [namespace delete foo]
+} {{} {}}
+
+test namespace-27.1 {NamespaceForgetCmd, no args} {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+ namespace forget
+} {}
+test namespace-27.2 {NamespaceForgetCmd, args must be valid namespaces} {
+ list [catch {namespace forget ::test_ns_1::xxx} msg] $msg
+} {1 {unknown namespace in namespace forget pattern "::test_ns_1::xxx"}}
+test namespace-27.3 {NamespaceForgetCmd, arg is forgotten} {
+ namespace eval test_ns_1 {
+ namespace export cmd*
+ proc cmd1 {args} {return "cmd1: $args"}
+ proc cmd2 {args} {return "cmd2: $args"}
+ }
+ namespace eval test_ns_2 {
+ namespace import ::test_ns_1::*
+ namespace forget ::test_ns_1::cmd1
+ }
+ info commands ::test_ns_2::*
+} {::test_ns_2::cmd2}
+
+test namespace-28.1 {NamespaceImportCmd, no args} -setup {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+} -body {
+ namespace eval ::test_ns_1 {
+ proc foo {} {}
+ proc bar {} {}
+ proc boo {} {}
+ proc glorp {} {}
+ namespace export foo b*
+ }
+ namespace eval ::test_ns_2 {
+ namespace import ::test_ns_1::*
+ lsort [namespace import]
+ }
+} -cleanup {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+} -result {bar boo foo}
+test namespace-28.2 {NamespaceImportCmd, no args and just "-force"} {
+ namespace import -force
+} {}
+test namespace-28.3 {NamespaceImportCmd, arg is imported} {
+ namespace eval test_ns_1 {
+ namespace export cmd2
+ proc cmd1 {args} {return "cmd1: $args"}
+ proc cmd2 {args} {return "cmd2: $args"}
+ }
+ namespace eval test_ns_2 {
+ namespace import ::test_ns_1::*
+ namespace forget ::test_ns_1::cmd1
+ }
+ info commands test_ns_2::*
+} {::test_ns_2::cmd2}
+
+test namespace-29.1 {NamespaceInscopeCmd, bad args} {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+ list [catch {namespace inscope} msg] $msg
+} {1 {wrong # args: should be "namespace inscope name arg ?arg...?"}}
+test namespace-29.2 {NamespaceInscopeCmd, bad args} {
+ list [catch {namespace inscope ::} msg] $msg
+} {1 {wrong # args: should be "namespace inscope name arg ?arg...?"}}
+test namespace-29.3 {NamespaceInscopeCmd, specified ns must exist} -body {
+ namespace inscope test_ns_1 {set v}
+} -returnCodes error -result {namespace "test_ns_1" not found in "::"}
+test namespace-29.4 {NamespaceInscopeCmd, simple case} {
+ namespace eval test_ns_1 {
+ variable v 747
+ proc cmd {args} {
+ variable v
+ return "[namespace current]::cmd: v=$v, args=$args"
+ }
+ }
+ namespace inscope test_ns_1 cmd
+} {::test_ns_1::cmd: v=747, args=}
+test namespace-29.5 {NamespaceInscopeCmd, has lappend semantics} -setup {
+ namespace eval test_ns_1 {
+ variable v 747
+ proc cmd {args} {
+ variable v
+ return "[namespace current]::cmd: v=$v, args=$args"
+ }
+ }
+} -body {
+ list [namespace inscope test_ns_1 cmd x y z] \
+ [namespace eval test_ns_1 [concat cmd [list x y z]]]
+} -result {{::test_ns_1::cmd: v=747, args=x y z} {::test_ns_1::cmd: v=747, args=x y z}}
+test namespace-29.6 {NamespaceInscopeCmd, 1400572} -setup {
+ namespace eval test_ns_1 {}
+} -body {
+ namespace inscope test_ns_1 {info level 0}
+} -result {namespace inscope test_ns_1 {info level 0}}
+
+test namespace-30.1 {NamespaceOriginCmd, bad args} {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+ list [catch {namespace origin} msg] $msg
+} {1 {wrong # args: should be "namespace origin name"}}
+test namespace-30.2 {NamespaceOriginCmd, bad args} {
+ list [catch {namespace origin x y} msg] $msg
+} {1 {wrong # args: should be "namespace origin name"}}
+test namespace-30.3 {NamespaceOriginCmd, command not found} {
+ list [catch {namespace origin fred} msg] $msg
+} {1 {invalid command name "fred"}}
+test namespace-30.4 {NamespaceOriginCmd, command isn't imported} {
+ namespace origin set
+} {::set}
+test namespace-30.5 {NamespaceOriginCmd, imported command} {
+ namespace eval test_ns_1 {
+ namespace export cmd*
+ proc cmd1 {args} {return "cmd1: $args"}
+ proc cmd2 {args} {return "cmd2: $args"}
+ }
+ namespace eval test_ns_2 {
+ namespace export *
+ namespace import ::test_ns_1::*
+ proc p {} {}
+ }
+ namespace eval test_ns_3 {
+ namespace import ::test_ns_2::*
+ list [namespace origin foreach] \
+ [namespace origin p] \
+ [namespace origin cmd1] \
+ [namespace origin ::test_ns_2::cmd2]
+ }
+} {::foreach ::test_ns_2::p ::test_ns_1::cmd1 ::test_ns_1::cmd2}
+
+test namespace-31.1 {NamespaceParentCmd, bad args} {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+ list [catch {namespace parent a b} msg] $msg
+} {1 {wrong # args: should be "namespace parent ?name?"}}
+test namespace-31.2 {NamespaceParentCmd, no args} {
+ namespace parent
+} {}
+test namespace-31.3 {NamespaceParentCmd, namespace specified} {
+ namespace eval test_ns_1 {
+ namespace eval test_ns_2 {
+ namespace eval test_ns_3 {}
+ }
+ }
+ list [namespace parent ::] \
+ [namespace parent test_ns_1::test_ns_2] \
+ [namespace eval test_ns_1::test_ns_2::test_ns_3 {namespace parent ::test_ns_1::test_ns_2}]
+} {{} ::test_ns_1 ::test_ns_1}
+test namespace-31.4 {NamespaceParentCmd, bad namespace specified} -body {
+ namespace parent test_ns_1::test_ns_foo
+} -returnCodes error -result {namespace "test_ns_1::test_ns_foo" not found in "::"}
+
+test namespace-32.1 {NamespaceQualifiersCmd, bad args} {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+ list [catch {namespace qualifiers} msg] $msg
+} {1 {wrong # args: should be "namespace qualifiers string"}}
+test namespace-32.2 {NamespaceQualifiersCmd, bad args} {
+ list [catch {namespace qualifiers x y} msg] $msg
+} {1 {wrong # args: should be "namespace qualifiers string"}}
+test namespace-32.3 {NamespaceQualifiersCmd, simple name} {
+ namespace qualifiers foo
+} {}
+test namespace-32.4 {NamespaceQualifiersCmd, leading ::} {
+ namespace qualifiers ::x::y::z
+} {::x::y}
+test namespace-32.5 {NamespaceQualifiersCmd, no leading ::} {
+ namespace qualifiers a::b
+} {a}
+test namespace-32.6 {NamespaceQualifiersCmd, :: argument} {
+ namespace qualifiers ::
+} {}
+test namespace-32.7 {NamespaceQualifiersCmd, odd number of :s} {
+ namespace qualifiers :::::
+} {}
+test namespace-32.8 {NamespaceQualifiersCmd, odd number of :s} {
+ namespace qualifiers foo:::
+} {foo}
+
+test namespace-33.1 {NamespaceTailCmd, bad args} {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+ list [catch {namespace tail} msg] $msg
+} {1 {wrong # args: should be "namespace tail string"}}
+test namespace-33.2 {NamespaceTailCmd, bad args} {
+ list [catch {namespace tail x y} msg] $msg
+} {1 {wrong # args: should be "namespace tail string"}}
+test namespace-33.3 {NamespaceTailCmd, simple name} {
+ namespace tail foo
+} {foo}
+test namespace-33.4 {NamespaceTailCmd, leading ::} {
+ namespace tail ::x::y::z
+} {z}
+test namespace-33.5 {NamespaceTailCmd, no leading ::} {
+ namespace tail a::b
+} {b}
+test namespace-33.6 {NamespaceTailCmd, :: argument} {
+ namespace tail ::
+} {}
+test namespace-33.7 {NamespaceTailCmd, odd number of :s} {
+ namespace tail :::::
+} {}
+test namespace-33.8 {NamespaceTailCmd, odd number of :s} {
+ namespace tail foo:::
+} {}
+
+test namespace-34.1 {NamespaceWhichCmd, bad args} {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+ list [catch {namespace which} msg] $msg
+} {1 {wrong # args: should be "namespace which ?-command? ?-variable? name"}}
+test namespace-34.2 {NamespaceWhichCmd, bad args} {
+ list [catch {namespace which -fred x} msg] $msg
+} {1 {wrong # args: should be "namespace which ?-command? ?-variable? name"}}
+test namespace-34.3 {NamespaceWhichCmd, single arg is always command name} {
+ namespace which -command
+} {}
+test namespace-34.4 {NamespaceWhichCmd, bad args} {
+ list [catch {namespace which a b} msg] $msg
+} {1 {wrong # args: should be "namespace which ?-command? ?-variable? name"}}
+test namespace-34.5 {NamespaceWhichCmd, command lookup} -setup {
+ catch {namespace delete {*}[namespace children test_ns_*]}
+ namespace eval test_ns_1 {
+ namespace export cmd*
+ variable v1 111
+ proc cmd1 {args} {return "cmd1: $args"}
+ proc cmd2 {args} {return "cmd2: $args"}
+ }
+ namespace eval test_ns_2 {
+ namespace export *
+ namespace import ::test_ns_1::*
+ variable v2 222
+ proc p {} {}
+ }
+} -body {
+ namespace eval test_ns_3 {
+ namespace import ::test_ns_2::*
+ variable v3 333
+ list [namespace which -command foreach] \
+ [namespace which -command p] \
+ [namespace which -command cmd1] \
+ [namespace which -command ::test_ns_2::cmd2] \
+ [catch {namespace which -command ::test_ns_2::noSuchCmd} msg] $msg
+ }
+} -result {::foreach ::test_ns_3::p ::test_ns_3::cmd1 ::test_ns_2::cmd2 0 {}}
+test namespace-34.6 {NamespaceWhichCmd, -command is default} -setup {
+ catch {namespace delete {*}[namespace children test_ns_*]}
+ namespace eval test_ns_1 {
+ namespace export cmd*
+ proc cmd1 {args} {return "cmd1: $args"}
+ proc cmd2 {args} {return "cmd2: $args"}
+ }
+ namespace eval test_ns_2 {
+ namespace export *
+ namespace import ::test_ns_1::*
+ proc p {} {}
+ }
+ namespace eval test_ns_3 {
+ namespace import ::test_ns_2::*
+ }
+} -body {
+ namespace eval test_ns_3 {
+ list [namespace which foreach] \
+ [namespace which p] \
+ [namespace which cmd1] \
+ [namespace which ::test_ns_2::cmd2]
+ }
+} -result {::foreach ::test_ns_3::p ::test_ns_3::cmd1 ::test_ns_2::cmd2}
+test namespace-34.7 {NamespaceWhichCmd, variable lookup} -setup {
+ catch {namespace delete {*}[namespace children test_ns_*]}
+ namespace eval test_ns_1 {
+ namespace export cmd*
+ proc cmd1 {args} {return "cmd1: $args"}
+ proc cmd2 {args} {return "cmd2: $args"}
+ }
+ namespace eval test_ns_2 {
+ namespace export *
+ namespace import ::test_ns_1::*
+ variable v2 222
+ proc p {} {}
+ }
+ namespace eval test_ns_3 {
+ variable v3 333
+ namespace import ::test_ns_2::*
+ }
+} -body {
+ namespace eval test_ns_3 {
+ list [namespace which -variable env] \
+ [namespace which -variable v3] \
+ [namespace which -variable ::test_ns_2::v2] \
+ [catch {namespace which -variable ::test_ns_2::noSuchVar} msg] $msg
+ }
+} -result {::env ::test_ns_3::v3 ::test_ns_2::v2 0 {}}
+
+test namespace-35.1 {FreeNsNameInternalRep, resulting ref count > 0} -setup {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+} -body {
+ namespace eval test_ns_1 {
+ proc p {} {
+ namespace delete [namespace current]
+ return [namespace current]
+ }
+ }
+ test_ns_1::p
+} -result {::test_ns_1}
+test namespace-35.2 {FreeNsNameInternalRep, resulting ref count == 0} {
+ namespace eval test_ns_1 {
+ proc q {} {
+ return [namespace current]
+ }
+ }
+ list [test_ns_1::q] \
+ [namespace delete test_ns_1] \
+ [catch {test_ns_1::q} msg] $msg
+} {::test_ns_1 {} 1 {invalid command name "test_ns_1::q"}}
+
+catch {unset x}
+catch {unset y}
+test namespace-36.1 {DupNsNameInternalRep} {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+ namespace eval test_ns_1 {}
+ set x "::test_ns_1"
+ list [namespace parent $x] [set y $x] [namespace parent $y]
+} {:: ::test_ns_1 ::}
+catch {unset x}
+catch {unset y}
+
+test namespace-37.1 {SetNsNameFromAny, ns name found} {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+ namespace eval test_ns_1::test_ns_2 {}
+ namespace eval test_ns_1 {
+ namespace children ::test_ns_1
+ }
+} {::test_ns_1::test_ns_2}
+test namespace-37.2 {SetNsNameFromAny, ns name not found} -body {
+ namespace eval test_ns_1 {
+ namespace children ::test_ns_1::test_ns_foo
+ }
+} -returnCodes error -result {namespace "::test_ns_1::test_ns_foo" not found}
+
+test namespace-38.1 {UpdateStringOfNsName} {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+ ;# Tcl_NamespaceObjCmd calls UpdateStringOfNsName to get subcmd name
+ list [namespace eval {} {namespace current}] \
+ [namespace eval {} {namespace current}]
+} {:: ::}
+
+test namespace-39.1 {NamespaceExistsCmd} {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+ namespace eval ::test_ns_z::test_me { variable foo }
+ list [namespace exists ::] \
+ [namespace exists ::bogus_namespace] \
+ [namespace exists ::test_ns_z] \
+ [namespace exists test_ns_z] \
+ [namespace exists ::test_ns_z::foo] \
+ [namespace exists ::test_ns_z::test_me] \
+ [namespace eval ::test_ns_z { namespace exists ::test_me }] \
+ [namespace eval ::test_ns_z { namespace exists test_me }] \
+ [namespace exists :::::test_ns_z]
+} {1 0 1 1 0 1 0 1 1}
+test namespace-39.2 {NamespaceExistsCmd error} {
+ list [catch {namespace exists} msg] $msg
+} {1 {wrong # args: should be "namespace exists name"}}
+test namespace-39.3 {NamespaceExistsCmd error} {
+ list [catch {namespace exists a b} msg] $msg
+} {1 {wrong # args: should be "namespace exists name"}}
+
+test namespace-40.1 {Ignoring namespace proc "unknown"} -setup {
+ rename unknown _unknown
+} -body {
+ proc unknown args {return global}
+ namespace eval ns {proc unknown args {return local}}
+ list [namespace eval ns aaa bbb] [namespace eval ns aaa]
+} -cleanup {
+ rename unknown {}
+ rename _unknown unknown
+ namespace delete ns
+} -result {global global}
+
+test namespace-41.1 {Shadowing byte-compiled commands, Bug: 231259} {
+ set res {}
+ namespace eval ns {
+ set res {}
+ proc test {} {
+ set ::g 0
+ }
+ lappend ::res [test]
+ proc set {a b} {
+ ::set a [incr b]
+ }
+ lappend ::res [test]
+ }
+ namespace delete ns
+ set res
+} {0 1}
+test namespace-41.2 {Shadowing byte-compiled commands, Bug: 231259} {
+ set res {}
+ namespace eval ns {}
+ proc ns::a {i} {
+ variable b
+ proc set args {return "New proc is called"}
+ return [set b $i]
+ }
+ ns::a 1
+ set res [ns::a 2]
+ namespace delete ns
+ set res
+} {New proc is called}
+test namespace-41.3 {Shadowing byte-compiled commands, Bugs: 231259, 729692} {
+ set res {}
+ namespace eval ns {
+ variable b 0
+ }
+ proc ns::a {i} {
+ variable b
+ proc set args {return "New proc is called"}
+ return [set b $i]
+ }
+ set res [list [ns::a 1] $ns::b]
+ namespace delete ns
+ set res
+} {{New proc is called} 0}
+
+# Ensembles (TIP#112)
+
+test namespace-42.1 {ensembles: basic} {
+ namespace eval ns {
+ namespace export x
+ proc x {} {format 1}
+ namespace ensemble create
+ }
+ list [info command ns] [ns x] [namespace delete ns] [info command ns]
+} {ns 1 {} {}}
+test namespace-42.2 {ensembles: basic} {
+ namespace eval ns {
+ namespace export x
+ proc x {} {format 1}
+ namespace ensemble create
+ }
+ rename ns foo
+ list [info command foo] [foo x] [namespace delete ns] [info command foo]
+} {foo 1 {} {}}
+test namespace-42.3 {ensembles: basic} {
+ namespace eval ns {
+ namespace export x*
+ proc x1 {} {format 1}
+ proc x2 {} {format 2}
+ namespace ensemble create
+ }
+ set result [list [ns x1] [ns x2]]
+ lappend result [catch {ns x} msg] $msg
+ rename ns {}
+ lappend result [info command ns::x1]
+ namespace delete ns
+ lappend result [info command ns::x1]
+} {1 2 1 {unknown or ambiguous subcommand "x": must be x1, or x2} ::ns::x1 {}}
+test namespace-42.4 {ensembles: basic} -body {
+ namespace eval ns {
+ namespace export y*
+ proc x1 {} {format 1}
+ proc x2 {} {format 2}
+ namespace ensemble create
+ }
+ list [catch {ns x} msg] $msg
+} -cleanup {
+ namespace delete ns
+} -result {1 {unknown subcommand "x": namespace ::ns does not export any commands}}
+test namespace-42.5 {ensembles: basic} -body {
+ namespace eval ns {
+ namespace export x*
+ proc x1 {} {format 1}
+ proc x2 {} {format 2}
+ proc x3 {} {format 3}
+ namespace ensemble create
+ }
+ list [catch {ns x} msg] $msg
+} -cleanup {
+ namespace delete ns
+} -result {1 {unknown or ambiguous subcommand "x": must be x1, x2, or x3}}
+test namespace-42.6 {ensembles: nested} -body {
+ namespace eval ns {
+ namespace export x*
+ namespace eval x0 {
+ proc z {} {format 0}
+ namespace export z
+ namespace ensemble create
+ }
+ proc x1 {} {format 1}
+ proc x2 {} {format 2}
+ proc x3 {} {format 3}
+ namespace ensemble create
+ }
+ list [ns x0 z] [ns x1] [ns x2] [ns x3]
+} -cleanup {
+ namespace delete ns
+} -result {0 1 2 3}
+test namespace-42.7 {ensembles: nested} -body {
+ namespace eval ns {
+ namespace export x*
+ namespace eval x0 {
+ proc z {} {list [info level] [info level 1]}
+ namespace export z
+ namespace ensemble create
+ }
+ proc x1 {} {format 1}
+ proc x2 {} {format 2}
+ proc x3 {} {format 3}
+ namespace ensemble create
+ }
+ list [ns x0 z] [ns x1] [ns x2] [ns x3]
+} -cleanup {
+ namespace delete ns
+} -result {{1 z} 1 2 3}
+test namespace-42.8 {
+ ensembles: [Bug 1670091], panic due to pointer to a deallocated List
+ struct.
+} -setup {
+ proc demo args {}
+ variable target [list [namespace which demo] x]
+ proc trial args {variable target; string length $target}
+ trace add execution demo enter [namespace code trial]
+ namespace ensemble create -command foo -map [list bar $target]
+} -body {
+ foo bar
+} -cleanup {
+ unset target
+ rename demo {}
+ rename trial {}
+ rename foo {}
+} -result {}
+
+test namespace-42.9 {
+ ensembles: [Bug 4f6a1ebd64], segmentation fault due to pointer to a
+ deallocated List struct.
+} -setup {
+ namespace eval n {namespace ensemble create}
+ set lst [dict create one ::two]
+ namespace ensemble configure n -subcommands $lst -map $lst
+} -body {
+ n one
+} -cleanup {
+ namespace delete n
+ unset -nocomplain lst
+} -returnCodes error -match glob -result {invalid command name*}
+
+test namespace-42.10 {
+ ensembles: [Bug 4f6a1ebd64] segmentation fault due to pointer to a
+ deallocated List struct (this time with duplicate of one in "dict").
+} -setup {
+ namespace eval n {namespace ensemble create}
+ set lst [list one ::two one ::three]
+ namespace ensemble configure n -subcommands $lst -map $lst
+} -body {
+ n one
+} -cleanup {
+ namespace delete n
+ unset -nocomplain lst
+} -returnCodes error -match glob -result {invalid command name *three*}
+
+test namespace-43.1 {ensembles: dict-driven} {
+ namespace eval ns {
+ namespace export x*
+ proc x1 {} {format 1}
+ proc x2 {} {format 2}
+ namespace ensemble create -map {a x1 b x2}
+ }
+ set result [list [catch {ns c} msg] $msg [namespace ensemble exists ns]]
+ rename ns {}
+ lappend result [namespace ensemble exists ns]
+} {1 {unknown or ambiguous subcommand "c": must be a, or b} 1 0}
+test namespace-43.2 {ensembles: dict-driven} -body {
+ namespace eval ns {
+ namespace export x*
+ proc x1 {args} {list 1 $args}
+ proc x2 {args} {list 2 [llength $args]}
+ namespace ensemble create -map {
+ a ::ns::x1 b ::ns::x2 c {::ns::x1 .} d {::ns::x2 .}
+ }
+ }
+ list [ns a] [ns b] [ns c] [ns c foo] [ns d] [ns d foo]
+} -cleanup {
+ namespace delete ns
+} -result {{1 {}} {2 0} {1 .} {1 {. foo}} {2 1} {2 2}}
+set SETUP {
+ namespace eval ns {
+ namespace export a b
+ proc a args {format 1,[llength $args]}
+ proc b args {format 2,[llength $args]}
+ proc c args {format 3,[llength $args]}
+ proc d args {format 4,[llength $args]}
+ namespace ensemble create -subcommands {b c}
+ }
+}
+test namespace-43.3 {ensembles: list-driven} -setup $SETUP -body {
+ namespace delete ns
+} -result {}
+test namespace-43.4 {ensembles: list-driven} -setup $SETUP -body {
+ ns a foo bar boo spong wibble
+} -cleanup {namespace delete ns} -returnCodes error -result {unknown or ambiguous subcommand "a": must be b, or c}
+test namespace-43.5 {ensembles: list-driven} -setup $SETUP -body {
+ ns b foo bar boo spong wibble
+} -cleanup {namespace delete ns} -result 2,5
+test namespace-43.6 {ensembles: list-driven} -setup $SETUP -body {
+ ns c foo bar boo spong wibble
+} -cleanup {namespace delete ns} -result 3,5
+test namespace-43.7 {ensembles: list-driven} -setup $SETUP -body {
+ ns d foo bar boo spong wibble
+} -cleanup {namespace delete ns} -returnCodes error -result {unknown or ambiguous subcommand "d": must be b, or c}
+set SETUP {
+ namespace eval ns {
+ namespace export a b
+ proc a args {format 1,[llength $args]}
+ proc b args {format 2,[llength $args]}
+ proc c args {format 3,[llength $args]}
+ proc d args {format 4,[llength $args]}
+ namespace ensemble create -subcommands {b c} -map {c ::ns::d}
+ }
+}
+test namespace-43.8 {ensembles: list-and-map-driven} -setup $SETUP -body {
+ namespace delete ns
+} -result {}
+test namespace-43.9 {ensembles: list-and-map-driven} -setup $SETUP -body {
+ ns a foo bar boo spong wibble
+} -cleanup {namespace delete ns} -returnCodes error -result {unknown or ambiguous subcommand "a": must be b, or c}
+test namespace-43.10 {ensembles: list-and-map-driven} -setup $SETUP -body {
+ ns b foo bar boo spong wibble
+} -cleanup {namespace delete ns} -result 2,5
+test namespace-43.11 {ensembles: list-and-map-driven} -setup $SETUP -body {
+ ns c foo bar boo spong wibble
+} -cleanup {namespace delete ns} -result 4,5
+test namespace-43.12 {ensembles: list-and-map-driven} -setup $SETUP -body {
+ ns d foo bar boo spong wibble
+} -cleanup {namespace delete ns} -returnCodes error -result {unknown or ambiguous subcommand "d": must be b, or c}
+set SETUP {
+ namespace eval ns {
+ namespace export *
+ proc foo args {format bar}
+ proc spong args {format wibble}
+ namespace ensemble create -prefixes off
+ }
+}
+test namespace-43.13 {ensembles: turn off prefixes} -setup $SETUP -body {
+ namespace delete ns
+} -result {}
+test namespace-43.14 {ensembles: turn off prefixes} -setup $SETUP -body {
+ ns fo
+} -cleanup {namespace delete ns} -returnCodes error -result {unknown subcommand "fo": must be foo, or spong}
+test namespace-43.15 {ensembles: turn off prefixes} -setup $SETUP -body {
+ ns foo
+} -cleanup {namespace delete ns} -result bar
+test namespace-43.16 {ensembles: turn off prefixes} -setup $SETUP -body {
+ ns s
+} -cleanup {namespace delete ns} -returnCodes error -result {unknown subcommand "s": must be foo, or spong}
+test namespace-43.17 {ensembles: turn off prefixes} -setup $SETUP -body {
+ ns spong
+} -cleanup {namespace delete ns} -result wibble
+
+test namespace-44.1 {ensemble: errors} {
+ list [catch {namespace ensemble} msg] $msg
+} {1 {wrong # args: should be "namespace ensemble subcommand ?arg ...?"}}
+test namespace-44.2 {ensemble: errors} {
+ list [catch {namespace ensemble ?} msg] $msg
+} {1 {bad subcommand "?": must be configure, create, or exists}}
+test namespace-44.3 {ensemble: errors} {
+ namespace eval ns {
+ list [catch {namespace ensemble create -map x} msg] $msg
+ }
+} {1 {missing value to go with key}}
+test namespace-44.4 {ensemble: errors} {
+ namespace eval ns {
+ list [catch {namespace ensemble create -map {x {}}} msg] $msg
+ }
+} {1 {ensemble subcommand implementations must be non-empty lists}}
+test namespace-44.5 {ensemble: errors} -setup {
+ namespace ensemble create -command foobar -subcommands {foobarcget foobarconfigure}
+} -body {
+ foobar foobarcon
+} -cleanup {
+ rename foobar {}
+} -returnCodes error -result {invalid command name "foobarconfigure"}
+test namespace-44.6 {ensemble: errors} -returnCodes error -body {
+ namespace ensemble create gorp
+} -result {wrong # args: should be "namespace ensemble create ?option value ...?"}
+
+test namespace-45.1 {ensemble: introspection} {
+ namespace eval ns {
+ namespace export x
+ proc x {} {}
+ namespace ensemble create
+ set ::result [namespace ensemble configure ::ns]
+ }
+ namespace delete ns
+ set result
+} {-map {} -namespace ::ns -parameters {} -prefixes 1 -subcommands {} -unknown {}}
+test namespace-45.2 {ensemble: introspection} {
+ namespace eval ns {
+ namespace export x
+ proc x {} {}
+ namespace ensemble create -map {A x}
+ set ::result [namespace ensemble configure ::ns -map]
+ }
+ namespace delete ns
+ set result
+} {A ::ns::x}
+
+test namespace-46.1 {ensemble: modification} {
+ namespace eval ns {
+ namespace export x
+ proc x {} {format 123}
+ # Ensemble maps A->x
+ namespace ensemble create -command ns -map {A ::ns::x}
+ set ::result [list [namespace ensemble configure ns -map] [ns A]]
+ # Ensemble maps B->x
+ namespace ensemble configure ns -map {B ::ns::x}
+ lappend ::result [namespace ensemble configure ns -map] [ns B]
+ # Ensemble maps x->x
+ namespace ensemble configure ns -map {}
+ lappend ::result [namespace ensemble configure ns -map] [ns x]
+ }
+ namespace delete ns
+ set result
+} {{A ::ns::x} 123 {B ::ns::x} 123 {} 123}
+test namespace-46.2 {ensemble: ensembles really use current export list} {
+ namespace eval ns {
+ namespace export x1
+ proc x1 {} {format 1}
+ proc x2 {} {format 1}
+ namespace ensemble create
+ }
+ catch {ns ?} msg; set result [list $msg]
+ namespace eval ns {namespace export x*}
+ catch {ns ?} msg; lappend result $msg
+ rename ns::x1 {}
+ catch {ns ?} msg; lappend result $msg
+ namespace delete ns
+ set result
+} {{unknown or ambiguous subcommand "?": must be x1} {unknown or ambiguous subcommand "?": must be x1, or x2} {unknown or ambiguous subcommand "?": must be x2}}
+test namespace-46.3 {ensemble: implementation errors} {
+ namespace eval ns {
+ variable count 0
+ namespace ensemble create -map {
+ a {::lappend ::result}
+ b {::incr ::ns::count}
+ }
+ }
+ set result {}
+ lappend result [catch { ns } msg] $msg
+ ns a [ns b 10]
+ catch {rename p {}}
+ rename ns p
+ p a [p b 3000]
+ lappend result $ns::count
+ namespace delete ns
+ lappend result [info command p]
+} {1 {wrong # args: should be "ns subcommand ?arg ...?"} 10 3010 3010 {}}
+test namespace-46.4 {ensemble: implementation errors} {
+ namespace eval ns {
+ namespace ensemble create
+ }
+ set result [info command ns]
+ lappend result [catch {ns ?} msg] $msg
+ namespace delete ns
+ set result
+} {ns 1 {unknown subcommand "?": namespace ::ns does not export any commands}}
+test namespace-46.5 {ensemble: implementation errors} {
+ namespace eval ns {
+ namespace ensemble create -map {makeError ::error}
+ }
+ list [catch {ns makeError "an error happened"} msg] $msg $::errorInfo [namespace delete ns]
+} {1 {an error happened} {an error happened
+ while executing
+"ns makeError "an error happened""} {}}
+test namespace-46.6 {ensemble: implementation renames/deletes itself} {
+ namespace eval ns {
+ namespace ensemble create -map {to ::rename}
+ }
+ ns to ns foo
+ foo to foo bar
+ bar to bar spong
+ spong to spong {}
+ namespace delete ns
+} {}
+test namespace-46.7 {ensemble: implementation deletes its namespace} {
+ namespace eval ns {
+ namespace ensemble create -map {kill {::namespace delete}}
+ }
+ ns kill ns
+} {}
+test namespace-46.8 {ensemble: implementation deletes its namespace} {
+ namespace eval ns {
+ namespace export *
+ proc foo {} {
+ variable x 1
+ bar
+ # Tricky; what is the correct return value anyway?
+ info exist x
+ }
+ proc bar {} {
+ namespace delete [namespace current]
+ }
+ namespace ensemble create
+ }
+ list [ns foo] [info exist ns::x]
+} {1 0}
+test namespace-46.9 {ensemble: configuring really configures things} {
+ namespace eval ns {
+ namespace ensemble create -map {a a} -prefixes 0
+ }
+ set result [list [catch {ns x} msg] $msg]
+ namespace ensemble configure ns -map {b b}
+ lappend result [catch {ns x} msg] $msg
+ namespace delete ns
+ set result
+} {1 {unknown subcommand "x": must be a} 1 {unknown subcommand "x": must be b}}
+
+test namespace-47.1 {ensemble: unknown handler} {
+ set log {}
+ namespace eval ns {
+ namespace export {[a-z]*}
+ proc Magic {ensemble subcmd args} {
+ global log
+ if {[string match {[a-z]*} $subcmd]} {
+ lappend log "making $subcmd"
+ proc $subcmd args {
+ global log
+ lappend log "running [info level 0]"
+ llength $args
+ }
+ } else {
+ lappend log "unknown $subcmd - args = $args"
+ return -code error \
+ "unknown or protected subcommand \"$subcmd\""
+ }
+ }
+ namespace ensemble create -unknown ::ns::Magic
+ }
+ set result {}
+ lappend result [catch {ns a b c} msg] $msg
+ lappend result [catch {ns a b c} msg] $msg
+ lappend result [catch {ns b c d} msg] $msg
+ lappend result [catch {ns c d e} msg] $msg
+ lappend result [catch {ns Magic foo bar spong wibble} msg] $msg
+ list $result [lsort [info commands ::ns::*]] $log [namespace delete ns]
+} {{0 2 0 2 0 2 0 2 1 {unknown or protected subcommand "Magic"}} {::ns::Magic ::ns::a ::ns::b ::ns::c} {{making a} {running a b c} {running a b c} {making b} {running b c d} {making c} {running c d e} {unknown Magic - args = foo bar spong wibble}} {}}
+test namespace-47.2 {ensemble: unknown handler} {
+ namespace eval ns {
+ namespace export {[a-z]*}
+ proc Magic {ensemble subcmd args} {
+ error foobar
+ }
+ namespace ensemble create -unknown ::ns::Magic
+ }
+ list [catch {ns spong} msg] $msg $::errorInfo [namespace delete ns]
+} {1 foobar {foobar
+ while executing
+"error foobar"
+ (procedure "::ns::Magic" line 2)
+ invoked from within
+"::ns::Magic ::ns spong"
+ (ensemble unknown subcommand handler)
+ invoked from within
+"ns spong"} {}}
+test namespace-47.3 {ensemble: unknown handler} {
+ namespace eval ns {
+ variable count 0
+ namespace export {[a-z]*}
+ proc a {} {}
+ proc c {} {}
+ proc Magic {ensemble subcmd args} {
+ variable count
+ incr count
+ proc b {} {}
+ }
+ namespace ensemble create -unknown ::ns::Magic
+ }
+ list [catch {ns spong} msg] $msg $ns::count [namespace delete ns]
+} {1 {unknown or ambiguous subcommand "spong": must be a, b, or c} 1 {}}
+test namespace-47.4 {ensemble: unknown handler} {
+ namespace eval ns {
+ namespace export {[a-z]*}
+ proc Magic {ensemble subcmd args} {
+ return -code break
+ }
+ namespace ensemble create -unknown ::ns::Magic
+ }
+ list [catch {ns spong} msg] $msg $::errorInfo [namespace delete ns]
+} {1 {unknown subcommand handler returned bad code: break} {unknown subcommand handler returned bad code: break
+ result of ensemble unknown subcommand handler: ::ns::Magic ::ns spong
+ invoked from within
+"ns spong"} {}}
+test namespace-47.5 {ensemble: unknown handler} {
+ namespace ensemble create -command foo -unknown bar
+ proc bar {args} {
+ global result target
+ lappend result "LOG $args"
+ return $target
+ }
+ set result {}
+ set target {}
+ lappend result [catch {foo bar} msg] $msg
+ set target {lappend result boo hoo}
+ lappend result [catch {foo bar} msg] $msg [namespace ensemble config foo]
+ rename foo {}
+ set result
+} {{LOG ::foo bar} 1 {unknown subcommand "bar": namespace :: does not export any commands} {LOG ::foo bar} boo hoo 0 {{LOG ::foo bar} 1 {unknown subcommand "bar": namespace :: does not export any commands} {LOG ::foo bar} boo hoo} {-map {} -namespace :: -parameters {} -prefixes 1 -subcommands {} -unknown bar}}
+test namespace-47.6 {ensemble: unknown handler} {
+ namespace ensemble create -command foo -unknown bar
+ proc bar {args} {
+ return "\{"
+ }
+ set result [list [catch {foo bar} msg] $msg $::errorInfo]
+ rename foo {}
+ set result
+} {1 {unmatched open brace in list} {unmatched open brace in list
+ while parsing result of ensemble unknown subcommand handler
+ invoked from within
+"foo bar"}}
+test namespace-47.7 {ensemble: unknown handler, commands with spaces} {
+ namespace ensemble create -command foo -unknown bar
+ proc bar {args} {
+ list ::set ::x [join $args |]
+ }
+ set result [foo {one two three}]
+ rename foo {}
+ set result
+} {::foo|one two three}
+test namespace-47.8 {ensemble: unknown handler, commands with spaces} {
+ namespace ensemble create -command foo -unknown {bar boo}
+ proc bar {args} {
+ list ::set ::x [join $args |]
+ }
+ set result [foo {one two three}]
+ rename foo {}
+ set result
+} {boo|::foo|one two three}
+
+test namespace-48.1 {ensembles and namespace import: unknown handler} {
+ namespace eval foo {
+ namespace export bar
+ namespace ensemble create -command bar -unknown ::foo::u -subcomm x
+ proc u {ens args} {
+ global result
+ lappend result $ens $args
+ namespace ensemble config $ens -subcommand {x y}
+ }
+ proc u2 {ens args} {
+ global result
+ lappend result $ens $args
+ namespace ensemble config ::bar -subcommand {x y z}
+ }
+ proc x args {
+ global result
+ lappend result XXX $args
+ }
+ proc y args {
+ global result
+ lappend result YYY $args
+ }
+ proc z args {
+ global result
+ lappend result ZZZ $args
+ }
+ }
+ namespace import -force foo::bar
+ set result [list [namespace ensemble config bar]]
+ bar x 123
+ bar y 456
+ namespace ensemble config bar -unknown ::foo::u2
+ bar z 789
+ namespace delete foo
+ set result
+} {{-map {} -namespace ::foo -parameters {} -prefixes 1 -subcommands x -unknown ::foo::u} XXX 123 ::foo::bar {y 456} YYY 456 ::foo::bar {z 789} ZZZ 789}
+test namespace-48.2 {ensembles and namespace import: exists} {
+ namespace eval foo {
+ namespace ensemble create -command ::foo::bar
+ namespace export bar
+ }
+ set result [namespace ensemble exist foo::bar]
+ lappend result [namespace ensemble exist bar]
+ namespace import foo::bar
+ lappend result [namespace ensemble exist bar]
+ rename foo::bar foo::bar2
+ lappend result [namespace ensemble exist bar] \
+ [namespace ensemble exist spong]
+ rename bar spong
+ lappend result [namespace ensemble exist bar] \
+ [namespace ensemble exist spong]
+ rename foo::bar2 {}
+ lappend result [namespace ensemble exist spong]
+ namespace delete foo
+ set result
+} {1 0 1 1 0 0 1 0}
+test namespace-48.3 {ensembles and namespace import: config} {
+ catch {rename spong {}}
+ namespace eval foo {
+ namespace ensemble create -command ::foo::bar
+ namespace export bar boo
+ proc boo {} {}
+ }
+ namespace import foo::bar foo::boo
+ set result [namespace ensemble config bar -namespace]
+ lappend result [catch {namespace ensemble config boo} msg] $msg
+ lappend result [catch {namespace ensemble config spong} msg] $msg
+ namespace delete foo
+ set result
+} {::foo 1 {"boo" is not an ensemble command} 1 {unknown command "spong"}}
+
+test namespace-49.1 {ensemble subcommand caching} -body {
+ namespace ens cre -command a -map {b {lappend result 1}}
+ namespace ens cre -command c -map {b {lappend result 2}}
+ proc x {} {a b; c b; a b; c b}
+ x
+} -result {1 2 1 2} -cleanup {
+ rename a {}
+ rename c {}
+ rename x {}
+}
+test namespace-49.2 {strange delete crash} -body {
+ namespace eval foo {namespace ensemble create -command ::bar}
+ trace add command ::bar delete DeleteTrace
+ proc DeleteTrace {old new op} {
+ trace remove command ::bar delete DeleteTrace
+ rename $old ""
+ # This next line caused a bus error in [Bug 1220058]
+ namespace delete foo
+ }
+ rename ::bar ""
+} -result "" -cleanup {
+ rename DeleteTrace ""
+}
+
+test namespace-50.1 {ensembles affect proc arguments error messages} -body {
+ namespace ens cre -command a -map {b {bb foo}}
+ proc bb {c d {e f} args} {list $c $args}
+ a b
+} -returnCodes error -result "wrong # args: should be \"a b d ?e? ?arg ...?\"" -cleanup {
+ rename a {}
+ rename bb {}
+}
+test namespace-50.2 {ensembles affect WrongNumArgs error messages} -body {
+ namespace ens cre -command a -map {b {string is}}
+ a b boolean
+} -returnCodes error -result "wrong # args: should be \"a b class ?-strict? ?-failindex var? str\"" -cleanup {
+ rename a {}
+}
+test namespace-50.3 {chained ensembles affect error messages} -body {
+ namespace ens cre -command a -map {b c}
+ namespace ens cre -command c -map {d e}
+ proc e f {}
+ a b d
+} -returnCodes error -result "wrong # args: should be \"a b d f\"" -cleanup {
+ rename a {}
+ rename c {}
+}
+test namespace-50.4 {chained ensembles affect error messages} -body {
+ namespace ens cre -command a -map {b {c d}}
+ namespace ens cre -command c -map {d {e f}}
+ proc e f {}
+ a b d
+} -returnCodes error -result "wrong # args: should be \"a b\"" -cleanup {
+ rename a {}
+ rename c {}
+}
+test namespace-50.5 {[4402cfa58c]} -setup {
+ proc bar {ev} {}
+ proc bingo {xx} {}
+ namespace ensemble create -command launch -map {foo bar event bingo}
+ set result {}
+} -body {
+ catch {launch foo} m; lappend result $m
+ catch {launch ev} m; lappend result $m
+ catch {launch foo} m; lappend result $m
+} -cleanup {
+ rename launch {}
+ rename bingo {}
+ rename bar {}
+} -result {{wrong # args: should be "launch foo ev"} {wrong # args: should be "launch event xx"} {wrong # args: should be "launch foo ev"}}
+test namespace-50.6 {[4402cfa58c]} -setup {
+ proc target {x y} {}
+ namespace ensemble create -command e2 -map {s2 target}
+ namespace ensemble create -command e1 -map {s1 e2}
+ set result {}
+} -body {
+ set s s
+ catch {e1 s1 s2 a} m; lappend result $m
+ catch {e1 $s s2 a} m; lappend result $m
+ catch {e1 s1 $s a} m; lappend result $m
+ catch {e1 $s $s a} m; lappend result $m
+} -cleanup {
+ rename e1 {}
+ rename e2 {}
+ rename target {}
+} -result {{wrong # args: should be "e1 s1 s2 x y"} {wrong # args: should be "e1 s1 s2 x y"} {wrong # args: should be "e1 s1 s2 x y"} {wrong # args: should be "e1 s1 s2 x y"}}
+test namespace-50.7 {[4402cfa58c]} -setup {
+ proc target {x y} {}
+ namespace ensemble create -command e2 -map {s2 target}
+ namespace ensemble create -command e1 -map {s1 e2} -parameters foo
+ set result {}
+} -body {
+ set s s
+ catch {e1 s2 s1 a} m; lappend result $m
+ catch {e1 $s s1 a} m; lappend result $m
+ catch {e1 s2 $s a} m; lappend result $m
+ catch {e1 $s $s a} m; lappend result $m
+} -cleanup {
+ rename e1 {}
+ rename e2 {}
+ rename target {}
+} -result {{wrong # args: should be "e1 s2 s1 x y"} {wrong # args: should be "e1 s2 s1 x y"} {wrong # args: should be "e1 s2 s1 x y"} {wrong # args: should be "e1 s2 s1 x y"}}
+test namespace-50.8 {[f961d7d1dd]} -setup {
+ proc target {} {}
+ namespace ensemble create -command e -map {s target} -parameters {{a b}}
+} -body {
+ e
+} -returnCodes error -result {wrong # args: should be "e {a b} subcommand ?arg ...?"} -cleanup {
+ rename e {}
+ rename target {}
+}
+test namespace-50.9 {[cea0344a51]} -body {
+ namespace eval foo {
+ namespace eval bar {
+ namespace delete foo
+ }
+ }
+} -returnCodes error -result {unknown namespace "foo" in namespace delete command}
+
+test namespace-51.1 {name resolution path control} -body {
+ namespace eval ::test_ns_1 {
+ namespace eval test_ns_2 {
+ proc pathtestA {} {
+ ::return [pathtestB],[pathtestC],[pathtestD],[namespace path]
+ }
+ proc pathtestC {} {
+ ::return 2
+ }
+ }
+ proc pathtestB {} {
+ return 1
+ }
+ proc pathtestC {} {
+ return 1
+ }
+ namespace path ::test_ns_1
+ }
+ proc ::pathtestB {} {
+ return global
+ }
+ proc ::pathtestD {} {
+ return global
+ }
+ test_ns_1::test_ns_2::pathtestA
+} -result "global,2,global," -cleanup {
+ namespace delete ::test_ns_1
+ catch {rename ::pathtestB {}}
+ catch {rename ::pathtestD {}}
+}
+test namespace-51.2 {name resolution path control} -body {
+ namespace eval ::test_ns_1 {
+ namespace eval test_ns_2 {
+ namespace path ::test_ns_1
+ proc pathtestA {} {
+ ::return [pathtestB],[pathtestC],[pathtestD],[namespace path]
+ }
+ proc pathtestC {} {
+ ::return 2
+ }
+ }
+ proc pathtestB {} {
+ return 1
+ }
+ proc pathtestC {} {
+ return 1
+ }
+ }
+ proc ::pathtestB {} {
+ return global
+ }
+ proc ::pathtestD {} {
+ return global
+ }
+ ::test_ns_1::test_ns_2::pathtestA
+} -result "1,2,global,::test_ns_1" -cleanup {
+ namespace delete ::test_ns_1
+ catch {rename ::pathtestB {}}
+ catch {rename ::pathtestD {}}
+}
+test namespace-51.3 {name resolution path control} -body {
+ namespace eval ::test_ns_1 {
+ namespace eval test_ns_2 {
+ proc pathtestA {} {
+ ::return [pathtestB],[pathtestC],[pathtestD],[namespace path]
+ }
+ proc pathtestC {} {
+ ::return 2
+ }
+ }
+ proc pathtestB {} {
+ return 1
+ }
+ proc pathtestC {} {
+ return 1
+ }
+ }
+ proc ::pathtestB {} {
+ return global
+ }
+ proc ::pathtestD {} {
+ return global
+ }
+ set result [::test_ns_1::test_ns_2::pathtestA]
+ namespace eval ::test_ns_1::test_ns_2 {
+ namespace path ::test_ns_1
+ }
+ lappend result [::test_ns_1::test_ns_2::pathtestA]
+ rename ::test_ns_1::pathtestB {}
+ lappend result [::test_ns_1::test_ns_2::pathtestA]
+} -result "global,2,global, 1,2,global,::test_ns_1 global,2,global,::test_ns_1" -cleanup {
+ namespace delete ::test_ns_1
+ catch {rename ::pathtestB {}}
+ catch {rename ::pathtestD {}}
+}
+test namespace-51.4 {name resolution path control} -body {
+ namespace eval ::test_ns_1 {
+ namespace eval test_ns_2 {
+ proc pathtestA {} {
+ ::return [pathtestB],[pathtestC],[pathtestD],[namespace path]
+ }
+ proc pathtestC {} {
+ ::return 2
+ }
+ }
+ proc pathtestB {} {
+ return 1
+ }
+ proc pathtestC {} {
+ return 1
+ }
+ }
+ proc ::pathtestB {} {
+ return global
+ }
+ proc ::pathtestD {} {
+ return global
+ }
+ set result [::test_ns_1::test_ns_2::pathtestA]
+ namespace eval ::test_ns_1::test_ns_2 {
+ namespace path ::test_ns_1
+ }
+ lappend result [::test_ns_1::test_ns_2::pathtestA]
+ namespace eval ::test_ns_1::test_ns_2 {
+ namespace path {}
+ }
+ lappend result [::test_ns_1::test_ns_2::pathtestA]
+} -result "global,2,global, 1,2,global,::test_ns_1 global,2,global," -cleanup {
+ namespace delete ::test_ns_1
+ catch {rename ::pathtestB {}}
+ catch {rename ::pathtestD {}}
+}
+test namespace-51.5 {name resolution path control} -body {
+ namespace eval ::test_ns_1 {
+ namespace eval test_ns_2 {
+ proc pathtestA {} {
+ ::return [pathtestB],[pathtestC],[pathtestD],[namespace path]
+ }
+ proc pathtestC {} {
+ ::return 2
+ }
+ namespace path ::test_ns_1
+ }
+ proc pathtestB {} {
+ return 1
+ }
+ proc pathtestC {} {
+ return 1
+ }
+ proc pathtestD {} {
+ return 1
+ }
+ }
+ proc ::pathtestB {} {
+ return global
+ }
+ proc ::pathtestD {} {
+ return global
+ }
+ set result [::test_ns_1::test_ns_2::pathtestA]
+ namespace eval ::test_ns_1::test_ns_2 {
+ namespace path {:: ::test_ns_1}
+ }
+ lappend result [::test_ns_1::test_ns_2::pathtestA]
+ rename ::test_ns_1::test_ns_2::pathtestC {}
+ lappend result [::test_ns_1::test_ns_2::pathtestA]
+} -result "1,2,1,::test_ns_1 {global,2,global,:: ::test_ns_1} {global,1,global,:: ::test_ns_1}" -cleanup {
+ namespace delete ::test_ns_1
+ catch {rename ::pathtestB {}}
+ catch {rename ::pathtestD {}}
+}
+test namespace-51.6 {name resolution path control} -body {
+ namespace eval ::test_ns_1 {
+ namespace eval test_ns_2 {
+ proc pathtestA {} {
+ ::return [pathtestB],[pathtestC],[pathtestD],[namespace path]
+ }
+ proc pathtestC {} {
+ ::return 2
+ }
+ namespace path ::test_ns_1
+ }
+ proc pathtestB {} {
+ return 1
+ }
+ proc pathtestC {} {
+ return 1
+ }
+ proc pathtestD {} {
+ return 1
+ }
+ }
+ proc ::pathtestB {} {
+ return global
+ }
+ proc ::pathtestD {} {
+ return global
+ }
+ set result [::test_ns_1::test_ns_2::pathtestA]
+ namespace eval ::test_ns_1::test_ns_2 {
+ namespace path {:: ::test_ns_1}
+ }
+ lappend result [::test_ns_1::test_ns_2::pathtestA]
+ rename ::test_ns_1::test_ns_2::pathtestC {}
+ lappend result [::test_ns_1::test_ns_2::pathtestA]
+ proc ::pathtestC {} {
+ return global
+ }
+ lappend result [::test_ns_1::test_ns_2::pathtestA]
+} -result "1,2,1,::test_ns_1 {global,2,global,:: ::test_ns_1} {global,1,global,:: ::test_ns_1} {global,global,global,:: ::test_ns_1}" -cleanup {
+ namespace delete ::test_ns_1
+ catch {rename ::pathtestB {}}
+ catch {rename ::pathtestD {}}
+}
+test namespace-51.7 {name resolution path control} -body {
+ namespace eval ::test_ns_1 {
+ }
+ namespace eval ::test_ns_2 {
+ namespace path ::test_ns_1
+ proc getpath {} {namespace path}
+ }
+ list [::test_ns_2::getpath] [namespace delete ::test_ns_1] [::test_ns_2::getpath]
+} -result {::test_ns_1 {} {}} -cleanup {
+ catch {namespace delete ::test_ns_1}
+ namespace delete ::test_ns_2
+}
+test namespace-51.8 {name resolution path control} -body {
+ namespace eval ::test_ns_1 {
+ }
+ namespace eval ::test_ns_2 {
+ }
+ namespace eval ::test_ns_3 {
+ }
+ namespace eval ::test_ns_4 {
+ namespace path {::test_ns_1 ::test_ns_2 ::test_ns_3}
+ proc getpath {} {namespace path}
+ }
+ list [::test_ns_4::getpath] [namespace delete ::test_ns_2] [::test_ns_4::getpath]
+} -result {{::test_ns_1 ::test_ns_2 ::test_ns_3} {} {::test_ns_1 ::test_ns_3}} -cleanup {
+ catch {namespace delete ::test_ns_1}
+ catch {namespace delete ::test_ns_2}
+ catch {namespace delete ::test_ns_3}
+ catch {namespace delete ::test_ns_4}
+}
+test namespace-51.9 {name resolution path control} -body {
+ namespace eval ::test_ns_1 {
+ }
+ namespace eval ::test_ns_2 {
+ }
+ namespace eval ::test_ns_3 {
+ }
+ namespace eval ::test_ns_4 {
+ namespace path {::test_ns_1 ::test_ns_2 ::test_ns_3}
+ proc getpath {} {namespace path}
+ }
+ list [::test_ns_4::getpath] [namespace delete ::test_ns_2] [namespace eval ::test_ns_2 {}] [::test_ns_4::getpath]
+} -result {{::test_ns_1 ::test_ns_2 ::test_ns_3} {} {} {::test_ns_1 ::test_ns_3}} -cleanup {
+ catch {namespace delete ::test_ns_1}
+ catch {namespace delete ::test_ns_2}
+ catch {namespace delete ::test_ns_3}
+ catch {namespace delete ::test_ns_4}
+}
+test namespace-51.10 {name resolution path control} -body {
+ namespace eval ::test_ns_1 {
+ namespace path does::not::exist
+ }
+} -returnCodes error -result {namespace "does::not::exist" not found in "::test_ns_1"} -cleanup {
+ catch {namespace delete ::test_ns_1}
+}
+test namespace-51.11 {name resolution path control} -body {
+ namespace eval ::test_ns_1 {
+ proc foo {} {return 1}
+ }
+ namespace eval ::test_ns_2 {
+ proc foo {} {return 2}
+ }
+ namespace eval ::test_ns_3 {
+ namespace path ::test_ns_1
+ }
+ namespace eval ::test_ns_4 {
+ namespace path {::test_ns_3 ::test_ns_2}
+ foo
+ }
+} -result 2 -cleanup {
+ catch {namespace delete ::test_ns_1}
+ catch {namespace delete ::test_ns_2}
+ catch {namespace delete ::test_ns_3}
+ catch {namespace delete ::test_ns_4}
+}
+test namespace-51.12 {name resolution path control} -body {
+ namespace eval ::test_ns_1 {
+ proc foo {} {return 1}
+ }
+ namespace eval ::test_ns_2 {
+ proc foo {} {return 2}
+ }
+ namespace eval ::test_ns_3 {
+ namespace path ::test_ns_1
+ }
+ namespace eval ::test_ns_4 {
+ namespace path {::test_ns_3 ::test_ns_2}
+ list [foo] [namespace delete ::test_ns_3] [foo]
+ }
+} -result {2 {} 2} -cleanup {
+ catch {namespace delete ::test_ns_1}
+ catch {namespace delete ::test_ns_2}
+ catch {namespace delete ::test_ns_3}
+ catch {namespace delete ::test_ns_4}
+}
+test namespace-51.13 {name resolution path control} -body {
+ set ::result {}
+ namespace eval ::test_ns_1 {
+ proc foo {} {lappend ::result 1}
+ }
+ namespace eval ::test_ns_2 {
+ proc foo {} {lappend ::result 2}
+ trace add command foo delete "namespace eval ::test_ns_3 foo;#"
+ }
+ namespace eval ::test_ns_3 {
+ proc foo {} {
+ lappend ::result 3
+ namespace delete [namespace current]
+ ::test_ns_4::bar
+ }
+ }
+ namespace eval ::test_ns_4 {
+ namespace path {::test_ns_2 ::test_ns_3 ::test_ns_1}
+ proc bar {} {
+ list [foo] [namespace delete ::test_ns_2] [foo]
+ }
+ bar
+ }
+ # Should the result be "2 {} {2 3 2 1}" instead?
+} -result {2 {} {2 3 1 1}} -cleanup {
+ catch {namespace delete ::test_ns_1}
+ catch {namespace delete ::test_ns_2}
+ catch {namespace delete ::test_ns_3}
+ catch {namespace delete ::test_ns_4}
+}
+test namespace-51.14 {name resolution path control} -setup {
+ foreach cmd [info commands foo*] {
+ rename $cmd {}
+ }
+ namespace eval ::test_ns_1 {}
+ namespace eval ::test_ns_2 {}
+ namespace eval ::test_ns_3 {}
+} -body {
+ proc foo0 {} {}
+ proc ::test_ns_1::foo1 {} {}
+ proc ::test_ns_2::foo2 {} {}
+ namespace eval ::test_ns_3 {
+ variable result {}
+ lappend result [info commands foo*]
+ namespace path {::test_ns_1 ::test_ns_2}
+ lappend result [info commands foo*]
+ proc foo2 {} {}
+ lappend result [info commands foo*]
+ rename foo2 {}
+ lappend result [info commands foo*]
+ namespace delete ::test_ns_1
+ lappend result [info commands foo*]
+ }
+} -cleanup {
+ catch {namespace delete ::test_ns_1}
+ catch {namespace delete ::test_ns_2}
+ catch {namespace delete ::test_ns_3}
+} -result {foo0 {foo1 foo2 foo0} {foo2 foo1 foo0} {foo1 foo2 foo0} {foo2 foo0}}
+test namespace-51.15 {namespace resolution path control} -body {
+ namespace eval ::test_ns_2 {
+ proc foo {} {return 2}
+ }
+ namespace eval ::test_ns_1 {
+ namespace eval test_ns_2 {
+ proc foo {} {return 1_2}
+ }
+ namespace eval test_ns_3 {
+ namespace path ::test_ns_1
+ test_ns_2::foo
+ }
+ }
+} -result 1_2 -cleanup {
+ namespace delete ::test_ns_1
+ namespace delete ::test_ns_2
+}
+test namespace-51.16 {Bug 1566526} {
+ interp create slave
+ slave eval namespace eval demo namespace path ::
+ interp delete slave
+} {}
+test namespace-51.17 {resolution epoch handling: Bug 2898722} -setup {
+ set result {}
+ catch {namespace delete ::a}
+} -body {
+ namespace eval ::a {
+ proc c {} {lappend ::result A}
+ c
+ namespace eval b {
+ variable d c
+ lappend ::result [catch { $d }]
+ }
+ lappend ::result .
+ namespace eval b {
+ namespace path [namespace parent]
+ $d;[format %c 99]
+ }
+ lappend ::result .
+ namespace eval b {
+ proc c {} {lappend ::result B}
+ $d;[format %c 99]
+ }
+ lappend ::result .
+ }
+ namespace eval ::a::b {
+ $d;[format %c 99]
+ lappend ::result .
+ proc ::c {} {lappend ::result G}
+ $d;[format %c 99]
+ lappend ::result .
+ rename ::a::c {}
+ $d;[format %c 99]
+ lappend ::result .
+ rename ::a::b::c {}
+ $d;[format %c 99]
+ }
+} -cleanup {
+ namespace delete ::a
+ catch {rename ::c {}}
+ unset result
+} -result {A 1 . A A . B B . B B . B B . B B . G G}
+test namespace-51.18 {Bug 3185407} -setup {
+ namespace eval ::test_ns_1 {}
+} -body {
+ namespace eval ::test_ns_1 {
+ variable result {}
+ namespace eval ns {proc foo {} {}}
+ namespace eval ns2 {proc foo {} {}}
+ namespace path {ns ns2}
+ variable x foo
+ lappend result [namespace which $x]
+ proc foo {} {}
+ lappend result [namespace which $x]
+ }
+} -cleanup {
+ namespace delete ::test_ns_1
+} -result {::test_ns_1::ns::foo ::test_ns_1::foo}
+
+# TIP 181 - namespace unknown tests
+test namespace-52.1 {unknown: default handler ::unknown} {
+ set result [list [namespace eval foobar { namespace unknown }]]
+ lappend result [namespace eval :: { namespace unknown }]
+ namespace delete foobar
+ set result
+} {{} ::unknown}
+test namespace-52.2 {unknown: default resolution global} {
+ proc ::foo {} { return "GLOBAL" }
+ namespace eval ::bar { proc foo {} { return "NAMESPACE" } }
+ namespace eval ::bar::jim { proc test {} { foo } }
+ set result [::bar::jim::test]
+ namespace delete ::bar
+ rename ::foo {}
+ set result
+} {GLOBAL}
+test namespace-52.3 {unknown: default resolution local} {
+ proc ::foo {} { return "GLOBAL" }
+ namespace eval ::bar {
+ proc foo {} { return "NAMESPACE" }
+ proc test {} { foo }
+ }
+ set result [::bar::test]
+ namespace delete ::bar
+ rename ::foo {}
+ set result
+} {NAMESPACE}
+test namespace-52.4 {unknown: set handler} {
+ namespace eval foo {
+ namespace unknown [list dispatch]
+ proc dispatch {args} { return $args }
+ proc test {} {
+ UnknownCmd a b c
+ }
+ }
+ set result [foo::test]
+ namespace delete foo
+ set result
+} {UnknownCmd a b c}
+test namespace-52.5 {unknown: search path before unknown is unaltered} {
+ proc ::test2 {args} { return "TEST2: $args" }
+ namespace eval foo {
+ namespace unknown [list dispatch]
+ proc dispatch {args} { return "UNKNOWN: $args" }
+ proc test1 {args} { return "TEST1: $args" }
+ proc test {} {
+ set result [list [test1 a b c]]
+ lappend result [test2 a b c]
+ lappend result [test3 a b c]
+ return $result
+ }
+ }
+ set result [foo::test]
+ namespace delete foo
+ rename ::test2 {}
+ set result
+} {{TEST1: a b c} {TEST2: a b c} {UNKNOWN: test3 a b c}}
+test namespace-52.6 {unknown: deleting handler restores default} {
+ rename ::unknown ::_unknown_orig
+ proc ::unknown {args} { return "DEFAULT: $args" }
+ namespace eval foo {
+ namespace unknown dummy
+ namespace unknown {}
+ }
+ set result [namespace eval foo { dummy a b c }]
+ rename ::unknown {}
+ rename ::_unknown_orig ::unknown
+ namespace delete foo
+ set result
+} {DEFAULT: dummy a b c}
+test namespace-52.7 {unknown: setting global unknown handler} {
+ proc ::myunknown {args} { return "MYUNKNOWN: $args" }
+ namespace eval :: { namespace unknown ::myunknown }
+ set result [namespace eval foo { dummy a b c }]
+ namespace eval :: { namespace unknown {} }
+ rename ::myunknown {}
+ namespace delete foo
+ set result
+} {MYUNKNOWN: dummy a b c}
+test namespace-52.8 {unknown: destroying and redefining global namespace} {
+ set i [interp create]
+ $i hide proc
+ $i hide namespace
+ $i hide return
+ $i invokehidden namespace delete ::
+ $i expose return
+ $i invokehidden proc unknown args { return "FINE" }
+ $i eval { foo bar bob }
+} {FINE}
+test namespace-52.9 {unknown: refcounting} -setup {
+ proc this args {
+ unset args ;# stop sharing
+ set copy [namespace unknown]
+ string length $copy ;# shimmer away list rep
+ info level 0
+ }
+ set handler [namespace unknown]
+ namespace unknown {this is a test}
+ catch {rename noSuchCommand {}}
+} -body {
+ noSuchCommand
+} -cleanup {
+ namespace unknown $handler
+ rename this {}
+} -result {this is a test noSuchCommand}
+testConstraint testevalobjv [llength [info commands testevalobjv]]
+test namespace-52.10 {unknown: with TCL_EVAL_GLOBAL} -constraints {
+ testevalobjv
+} -setup {
+ rename ::unknown unknown.save
+ proc ::unknown args {
+ set caller [uplevel 1 {namespace current}]
+ namespace eval $caller {
+ variable foo
+ return $foo
+ }
+ }
+ catch {rename ::noSuchCommand {}}
+} -body {
+ namespace eval :: {
+ variable foo SUCCESS
+ }
+ namespace eval test_ns_1 {
+ variable foo FAIL
+ testevalobjv 1 noSuchCommand
+ }
+} -cleanup {
+ unset -nocomplain ::foo
+ namespace delete test_ns_1
+ rename ::unknown {}
+ rename unknown.save ::unknown
+} -result SUCCESS
+test namespace-52.11 {unknown: with TCL_EVAL_INVOKE} -setup {
+ set handler [namespace eval :: {namespace unknown}]
+ namespace eval :: {namespace unknown unknown}
+ rename ::unknown unknown.save
+ namespace eval :: {
+ proc unknown args {
+ return SUCCESS
+ }
+ }
+ catch {rename ::noSuchCommand {}}
+ set ::slave [interp create]
+} -body {
+ $::slave alias bar noSuchCommand
+ namespace eval test_ns_1 {
+ namespace unknown unknown
+ proc unknown args {
+ return FAIL
+ }
+ $::slave eval bar
+ }
+} -cleanup {
+ interp delete $::slave
+ unset ::slave
+ namespace delete test_ns_1
+ rename ::unknown {}
+ rename unknown.save ::unknown
+ namespace eval :: [list namespace unknown $handler]
+} -result SUCCESS
+test namespace-52.12 {unknown: error case must not reset handler} -body {
+ namespace eval foo {
+ namespace unknown ok
+ catch {namespace unknown {{}{}{}}}
+ namespace unknown
+ }
+} -cleanup {
+ namespace delete foo
+} -result ok
+
+# TIP 314 - ensembles with parameters
+test namespace-53.1 {ensembles: parameters} {
+ namespace eval ns {
+ namespace export x
+ proc x {para} {list 1 $para}
+ namespace ensemble create -parameters {para1}
+ }
+ list [info command ns] [ns bar x] [namespace delete ns] [info command ns]
+} {ns {1 bar} {} {}}
+test namespace-53.2 {ensembles: parameters} -setup {
+ namespace eval ns {
+ namespace export x
+ proc x {para} {list 1 $para}
+ namespace ensemble create
+ }
+} -body {
+ namespace ensemble configure ns -parameters {para1}
+ rename ns foo
+ list [info command foo] [foo bar x] [namespace delete ns] [info command foo]
+} -result {foo {1 bar} {} {}}
+test namespace-53.3 {ensembles: parameters} -setup {
+ namespace eval ns {
+ namespace export x*
+ proc x1 {para} {list 1 $para}
+ proc x2 {para} {list 2 $para}
+ namespace ensemble create -parameters param1
+ }
+} -body {
+ set result [list [ns x2 x1] [ns x1 x2]]
+ lappend result [catch {ns x} msg] $msg
+ lappend result [catch {ns x x} msg] $msg
+ rename ns {}
+ lappend result [info command ns::x1]
+ namespace delete ns
+ lappend result [info command ns::x1]
+} -result\
+ {{1 x2} {2 x1}\
+ 1 {wrong # args: should be "ns param1 subcommand ?arg ...?"}\
+ 1 {unknown or ambiguous subcommand "x": must be x1, or x2}\
+ ::ns::x1 {}}
+test namespace-53.4 {ensembles: parameters} -setup {
+ namespace eval ns {
+ namespace export x*
+ proc x1 {a1 a2} {list 1 $a1 $a2}
+ proc x2 {a1 a2} {list 2 $a1 $a2}
+ proc x3 {a1 a2} {list 3 $a1 $a2}
+ namespace ensemble create
+ }
+} -body {
+ set result {}
+ lappend result [ns x1 x2 x3]
+ namespace ensemble configure ns -parameters p1
+ lappend result [ns x1 x2 x3]
+ namespace ensemble configure ns -parameters {p1 p2}
+ lappend result [ns x1 x2 x3]
+} -cleanup {
+ namespace delete ns
+} -result {{1 x2 x3} {2 x1 x3} {3 x1 x2}}
+test namespace-53.5 {ensembles: parameters} -setup {
+ namespace eval ns {
+ namespace export x*
+ proc x1 {para} {list 1 $para}
+ proc x2 {para} {list 2 $para}
+ proc x3 {para} {list 3 $para}
+ namespace ensemble create
+ }
+} -body {
+ set result [list [catch {ns x x1} msg] $msg]
+ lappend result [catch {ns x1 x} msg] $msg
+ namespace ensemble configure ns -parameters p1
+ lappend result [catch {ns x1 x} msg] $msg
+ lappend result [catch {ns x x1} msg] $msg
+} -cleanup {
+ namespace delete ns
+} -result\
+ {1 {unknown or ambiguous subcommand "x": must be x1, x2, or x3}\
+ 0 {1 x}\
+ 1 {unknown or ambiguous subcommand "x": must be x1, x2, or x3}\
+ 0 {1 x}}
+test namespace-53.6 {ensembles: nested} -setup {
+ namespace eval ns {
+ namespace export x*
+ namespace eval x0 {
+ proc z {args} {list 0 $args}
+ namespace export z
+ namespace ensemble create
+ }
+ proc x1 {args} {list 1 $args}
+ proc x2 {args} {list 2 $args}
+ proc x3 {args} {list 3 $args}
+ namespace ensemble create -parameters p
+ }
+} -body {
+ list [ns z x0] [ns z x1] [ns z x2] [ns z x3]
+} -cleanup {
+ namespace delete ns
+} -result {{0 {}} {1 z} {2 z} {3 z}}
+test namespace-53.7 {ensembles: parameters & wrong # args} -setup {
+ namespace eval ns {
+ namespace export x*
+ proc x1 {a1 a2 a3 a4} {list x1 $a1 $a2 $a3 $a4}
+ namespace ensemble create -parameters p1
+ }
+} -body {
+ set result {}
+ lappend result [catch {ns} msg] $msg
+ lappend result [catch {ns x1} msg] $msg
+ lappend result [catch {ns x1 x1} msg] $msg
+ lappend result [catch {ns x1 x1 x1} msg] $msg
+ lappend result [catch {ns x1 x1 x1 x1} msg] $msg
+ lappend result [catch {ns x1 x1 x1 x1 x1} msg] $msg
+} -cleanup {
+ namespace delete ns
+} -result\
+ {1 {wrong # args: should be "ns p1 subcommand ?arg ...?"}\
+ 1 {wrong # args: should be "ns p1 subcommand ?arg ...?"}\
+ 1 {wrong # args: should be "ns x1 x1 a2 a3 a4"}\
+ 1 {wrong # args: should be "ns x1 x1 a2 a3 a4"}\
+ 1 {wrong # args: should be "ns x1 x1 a2 a3 a4"}\
+ 0 {x1 x1 x1 x1 x1}}
+test namespace-53.8 {ensemble: unknown handler changing -parameters} -setup {
+ namespace eval ns {
+ namespace export x*
+ proc x1 {a1} {list 1 $a1}
+ proc Magic {ensemble subcmd args} {
+ namespace ensemble configure $ensemble\
+ -parameters [lrange p1 [llength [
+ namespace ensemble configure $ensemble -parameters
+ ]] 0]
+ list
+ }
+ namespace ensemble create -unknown ::ns::Magic
+ }
+} -body {
+ set result {}
+ lappend result [catch {ns x1 x2} msg] $msg [namespace ensemble configure ns -parameters]
+ lappend result [catch {ns x2 x1} msg] $msg [namespace ensemble configure ns -parameters]
+ lappend result [catch {ns x2 x3} msg] $msg [namespace ensemble configure ns -parameters]
+} -cleanup {
+ namespace delete ns
+} -result\
+ {0 {1 x2} {}\
+ 0 {1 x2} p1\
+ 1 {unknown or ambiguous subcommand "x2": must be x1} {}}
+test namespace-53.9 {ensemble: unknown handler changing -parameters,\
+ thereby eating all args} -setup {
+ namespace eval ns {
+ namespace export x*
+ proc x1 {args} {list 1 $args}
+ proc Magic {ensemble subcmd args} {
+ namespace ensemble configure $ensemble\
+ -parameters {p1 p2 p3 p4 p5}
+ list
+ }
+ namespace ensemble create -unknown ::ns::Magic
+ }
+} -body {
+ set result {}
+ lappend result [catch {ns x1 x2} msg] $msg [namespace ensemble configure ns -parameters]
+ lappend result [catch {ns x2 x1} msg] $msg [namespace ensemble configure ns -parameters]
+ lappend result [catch {ns a1 a2 a3 a4 a5 x1} msg] $msg [namespace ensemble configure ns -parameters]
+} -cleanup {
+ namespace delete ns
+} -result\
+ {0 {1 x2} {}\
+ 1 {wrong # args: should be "ns p1 p2 p3 p4 p5 subcommand ?arg ...?"} {p1 p2 p3 p4 p5}\
+ 0 {1 {a1 a2 a3 a4 a5}} {p1 p2 p3 p4 p5}}
+test namespace-53.10 {ensembles: nested rewrite} -setup {
+ namespace eval ns {
+ namespace export x
+ namespace eval x {
+ proc z0 {} {list 0}
+ proc z1 {a1} {list 1 $a1}
+ proc z2 {a1 a2} {list 2 $a1 $a2}
+ proc z3 {a1 a2 a3} {list 3 $a1 $a2 $a3}
+ namespace export z*
+ namespace ensemble create
+ }
+ namespace ensemble create -parameters p
+ }
+} -body {
+ set result {}
+ # In these cases, parsing the subensemble does not grab a new word.
+ lappend result [catch {ns z0 x} msg] $msg
+ lappend result [catch {ns z1 x} msg] $msg
+ lappend result [catch {ns z2 x} msg] $msg
+ lappend result [catch {ns z2 x v} msg] $msg
+ namespace ensemble configure ns::x -parameters q1
+ # In these cases, parsing the subensemble grabs a new word.
+ lappend result [catch {ns v x z0} msg] $msg
+ lappend result [catch {ns v x z1} msg] $msg
+ lappend result [catch {ns v x z2} msg] $msg
+ lappend result [catch {ns v x z2 v2} msg] $msg
+} -cleanup {
+ namespace delete ns
+} -result\
+ {0 0\
+ 1 {wrong # args: should be "ns z1 x a1"}\
+ 1 {wrong # args: should be "ns z2 x a1 a2"}\
+ 1 {wrong # args: should be "ns z2 x a1 a2"}\
+ 1 {wrong # args: should be "z0"}\
+ 0 {1 v}\
+ 1 {wrong # args: should be "ns v x z2 a2"}\
+ 0 {2 v v2}}
+test namespace-53.11 {ensembles: nested rewrite} -setup {
+ namespace eval ns {
+ namespace export x
+ namespace eval x {
+ proc z2 {a1 a2} {list 2 $a1 $a2}
+ namespace export z*
+ namespace ensemble create -parameter p
+ }
+ namespace ensemble create
+ }
+} -body {
+ list [catch {ns x 1 z2} msg] $msg
+} -cleanup {
+ namespace delete ns
+ unset -nocomplain msg
+} -result {1 {wrong # args: should be "ns x 1 z2 a2"}}
+
+test namespace-54.1 {leak on namespace deletion} -constraints {memory} \
+-setup {
+ proc getbytes {} {
+ set lines [split [memory info] "\n"]
+ lindex $lines 3 3
+ }
+} -body {
+ set end [getbytes]
+ for {set i 0} {$i < 5} {incr i} {
+ set ns ::y$i
+ namespace eval $ns {}
+ namespace delete $ns
+ set start $end
+ set end [getbytes]
+ }
+ set leakedBytes [expr {$end - $start}]
+} -cleanup {
+ rename getbytes {}
+ unset i ns start end
+} -result 0
+
+test namespace-55.1 {compiled ensembles inside compiled ensembles: Bug 6d2f249a01} {
+ info class [format %s constructor] oo::object
+} ""
+
+test namespace-56.1 {bug f97d4ee020: mutually-entangled deletion} {
+ namespace eval ::testing {
+ proc abc {} {}
+ proc def {} {}
+ trace add command abc delete "rename ::testing::def {}; #"
+ trace add command def delete "rename ::testing::abc {}; #"
+ }
+ namespace delete ::testing
+} {}
+test namespace-56.2 {bug f97d4ee020: mutually-entangled deletion} {
+ namespace eval ::testing {
+ namespace eval abc {proc xyz {} {}}
+ namespace eval def {proc xyz {} {}}
+ trace add command abc::xyz delete "namespace delete ::testing::def {}; #"
+ trace add command def::xyz delete "namespace delete ::testing::abc {}; #"
+ }
+ namespace delete ::testing
+} {}
+test namespace-56.3 {bug f97d4ee020: mutually-entangled deletion} {
+ namespace eval ::testing {
+ variable gone {}
+ oo::class create CB {
+ variable cmd
+ constructor other {set cmd $other}
+ destructor {rename $cmd {}; lappend ::testing::gone $cmd}
+ }
+ namespace eval abc {
+ ::testing::CB create def ::testing::abc::ghi
+ ::testing::CB create ghi ::testing::abc::def
+ }
+ namespace delete abc
+ try {
+ return [lsort $gone]
+ } finally {
+ namespace delete ::testing
+ }
+ }
+} {::testing::abc::def ::testing::abc::ghi}
+
+test namespace-56.4 {bug 16fe1b5807: names starting with ":"} {
+namespace eval : {
+ namespace ensemble create
+ namespace export *
+ proc p1 {} {
+ return 16fe1b5807
+ }
+}
+
+: p1
+} 16fe1b5807
+
+# cleanup
+catch {rename cmd1 {}}
+catch {unset l}
+catch {unset msg}
+catch {unset trigger}
+namespace delete {*}[namespace children :: test_ns_*]
+::tcltest::cleanupTests
+return
+
+# Local Variables:
+# mode: tcl
+# End:
generated by cgit v0.12 at 2024-10-22 18:06:00 (GMT)