diff options
author | dkf <donal.k.fellows@manchester.ac.uk> | 2024-06-16 20:37:46 (GMT) |
---|---|---|
committer | dkf <donal.k.fellows@manchester.ac.uk> | 2024-06-16 20:37:46 (GMT) |
commit | 3013ff330e1917f7d543a69bbbc50e19ac4e8090 (patch) | |
tree | 9e3143d7326bc70c5a47c6c035050fe2b036e69b | |
parent | fb74fa4d32a761402939c6c0343c205d05433b95 (diff) | |
parent | ba6d47e73b72aff7071511b6eba0d6142eab5d22 (diff) | |
download | tcl-3013ff330e1917f7d543a69bbbc50e19ac4e8090.zip tcl-3013ff330e1917f7d543a69bbbc50e19ac4e8090.tar.gz tcl-3013ff330e1917f7d543a69bbbc50e19ac4e8090.tar.bz2 |
Merge 8.7
-rw-r--r-- | generic/tclEnsemble.c | 1590 | ||||
-rw-r--r-- | generic/tclInt.h | 3 |
2 files changed, 840 insertions, 753 deletions
diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 3b7230a..a9bcf0c 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -18,6 +18,15 @@ */ static inline Tcl_Obj * NewNsObj(Tcl_Namespace *namespacePtr); +static Tcl_Command InitEnsembleFromOptions(Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int ReadOneEnsembleOption(Tcl_Interp *interp, + Tcl_Command token, Tcl_Obj *optionObj); +static int ReadAllEnsembleOptions(Tcl_Interp *interp, + Tcl_Command token); +static int SetEnsembleConfigOptions(Tcl_Interp *interp, + Tcl_Command token, int objc, + Tcl_Obj *const objv[]); static inline int EnsembleUnknownCallback(Tcl_Interp *interp, EnsembleConfig *ensemblePtr, int objc, Tcl_Obj *const objv[], Tcl_Obj **prefixObjPtr); @@ -85,7 +94,7 @@ static const Tcl_ObjType ensembleCmdType = { TCL_OBJTYPE_V0 }; -#define ECRSetInternalRep(objPtr, ecRepPtr) \ +#define ECRSetInternalRep(objPtr, ecRepPtr) \ do { \ Tcl_ObjInternalRep ir; \ ir.twoPtrValue.ptr1 = (ecRepPtr); \ @@ -93,11 +102,12 @@ static const Tcl_ObjType ensembleCmdType = { Tcl_StoreInternalRep((objPtr), &ensembleCmdType, &ir); \ } while (0) -#define ECRGetInternalRep(objPtr, ecRepPtr) \ +#define ECRGetInternalRep(objPtr, ecRepPtr) \ do { \ - const Tcl_ObjInternalRep *irPtr; \ - irPtr = TclFetchInternalRep((objPtr), &ensembleCmdType); \ - (ecRepPtr) = irPtr ? (EnsembleCmdRep *)irPtr->twoPtrValue.ptr1 : NULL; \ + const Tcl_ObjInternalRep *irPtr; \ + irPtr = TclFetchInternalRep((objPtr), &ensembleCmdType); \ + (ecRepPtr) = irPtr ? (EnsembleCmdRep *) \ + irPtr->twoPtrValue.ptr1 : NULL; \ } while (0) /* @@ -106,16 +116,28 @@ static const Tcl_ObjType ensembleCmdType = { */ typedef struct { - Tcl_Size 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. */ + Tcl_Size 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; +/* + *---------------------------------------------------------------------- + * + * NewNsObj -- + * + * Make an object that contains a namespace's name. + * + * TODO: + * This is a candidate for doing something better! + * + *---------------------------------------------------------------------- + */ static inline Tcl_Obj * NewNsObj( Tcl_Namespace *namespacePtr) @@ -125,7 +147,7 @@ NewNsObj( if (namespacePtr == TclGetGlobalNamespace(nsPtr->interp)) { return Tcl_NewStringObj("::", 2); } - return Tcl_NewStringObj(nsPtr->fullName, -1); + return Tcl_NewStringObj(nsPtr->fullName, TCL_AUTO_LENGTH); } /* @@ -157,21 +179,15 @@ TclNamespaceEnsembleCmd( 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; + Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp); + Tcl_Command token; /* The ensemble command. */ enum EnsSubcmds index; - int done; if (nsPtr == NULL || nsPtr->flags & NS_DEAD) { if (!Tcl_InterpDeleted(interp)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "tried to manipulate ensemble of deleted namespace", - -1)); + TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "DEAD", (char *)NULL); } return TCL_ERROR; @@ -180,26 +196,13 @@ TclNamespaceEnsembleCmd( if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?"); return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[1], ensembleSubcommands, + } else if (Tcl_GetIndexFromObj(interp, objv[1], ensembleSubcommands, "subcommand", 0, &index) != TCL_OK) { return TCL_ERROR; } switch (index) { - case ENS_CREATE: { - const char *name; - Tcl_Size len; - int allocatedMapFlag = 0; - /* - * Defaults - */ - Tcl_Obj *subcmdObj = NULL; - Tcl_Obj *mapObj = NULL; - int permitPrefix = 1; - Tcl_Obj *unknownObj = NULL; - Tcl_Obj *paramObj = NULL; - + case ENS_CREATE: /* * Check that we've got option-value pairs... [Bug 1558654] */ @@ -208,169 +211,11 @@ TclNamespaceEnsembleCmd( 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) { - enum EnsCreateOpts idx; - if (Tcl_GetIndexFromObj(interp, objv[0], ensembleCreateOptions, - "option", 0, &idx) != TCL_OK) { - if (allocatedMapFlag) { - Tcl_DecrRefCount(mapObj); - } - return TCL_ERROR; - } - switch (idx) { - 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", (char *)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, "::", (char *)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; - } + token = InitEnsembleFromOptions(interp, objc - 2, objv + 2); + if (token == NULL) { + return TCL_ERROR; } - 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 @@ -380,7 +225,6 @@ TclNamespaceEnsembleCmd( Tcl_ResetResult(interp); Tcl_GetCommandFullName(interp, token, Tcl_GetObjResult(interp)); return TCL_OK; - } case ENS_EXISTS: if (objc != 3) { @@ -403,265 +247,518 @@ TclNamespaceEnsembleCmd( } if (objc == 4) { - enum EnsConfigOpts idx; - Tcl_Obj *resultObj = NULL; /* silence gcc 4 warning */ + return ReadOneEnsembleOption(interp, token, objv[3]); + } else if (objc == 3) { + return ReadAllEnsembleOptions(interp, token); + } else { + return SetEnsembleConfigOptions(interp, token, objc - 3, objv + 3); + } - if (Tcl_GetIndexFromObj(interp, objv[3], ensembleConfigOptions, - "option", 0, &idx) != TCL_OK) { - return TCL_ERROR; + default: + Tcl_Panic("unexpected ensemble command"); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * InitEnsembleFromOptions -- + * + * Core of implementation of "namespace ensemble create". + * + * Results: + * Returns created ensemble's command token if successful, and NULL if + * anything goes wrong. + * + * Side effects: + * Creates the ensemble for the namespace if one did not previously + * exist. + * + * Note: + * Can't use SetEnsembleConfigOptions() here. Different (but overlapping) + * options are supported. + * + *---------------------------------------------------------------------- + */ +static Tcl_Command +InitEnsembleFromOptions( + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp); + Namespace *cxtPtr = nsPtr->parentPtr; + Namespace *altFoundNsPtr, *actualCxtPtr; + const char *name = nsPtr->name; + Tcl_Size len; + int allocatedMapFlag = 0; + enum EnsCreateOpts index; + Tcl_Command token; /* The created ensemble command. */ + Namespace *foundNsPtr; + const char *simpleName; + /* + * Defaults + */ + Tcl_Obj *subcmdObj = NULL; + Tcl_Obj *mapObj = NULL; + int permitPrefix = 1; + Tcl_Obj *unknownObj = NULL; + Tcl_Obj *paramObj = NULL; + + /* + * 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) { + goto error; + } + switch (index) { + case CRT_CMD: + name = TclGetString(objv[1]); + cxtPtr = nsPtr; + continue; + case CRT_SUBCMDS: + if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { + goto error; + } + subcmdObj = (len > 0 ? objv[1] : NULL); + continue; + case CRT_PARAM: + if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { + goto error; + } + paramObj = (len > 0 ? objv[1] : NULL); + continue; + case CRT_MAP: { + Tcl_Obj *patchedDict = NULL, *subcmdWordsObj, *listObj; + Tcl_DictSearch search; + int done; + + /* + * Verify that the map is sensible. + */ + + if (Tcl_DictObjFirst(interp, objv[1], &search, + &subcmdWordsObj, &listObj, &done) != TCL_OK) { + goto error; + } else if (done) { + mapObj = NULL; + continue; } - switch (idx) { - case CONF_SUBCMDS: - Tcl_GetEnsembleSubcommandList(NULL, token, &resultObj); - if (resultObj != NULL) { - Tcl_SetObjResult(interp, resultObj); + do { + Tcl_Obj **listv; + const char *cmd; + + if (TclListObjGetElements(interp, listObj, &len, + &listv) != TCL_OK) { + goto mapError; } - break; - case CONF_PARAM: - Tcl_GetEnsembleParameterList(NULL, token, &resultObj); - if (resultObj != NULL) { - Tcl_SetObjResult(interp, resultObj); + if (len < 1) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "ensemble subcommand implementations " + "must be non-empty lists", TCL_AUTO_LENGTH)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", + "EMPTY_TARGET", (char *)NULL); + goto mapError; } - break; - case CONF_MAP: - Tcl_GetEnsembleMappingDict(NULL, token, &resultObj); - if (resultObj != NULL) { - Tcl_SetObjResult(interp, resultObj); + 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, "::", (char *)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); } - 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_DictObjNext(&search, &subcmdWordsObj, &listObj, &done); + } while (!done); - Tcl_GetEnsembleFlags(NULL, token, &flags); - Tcl_SetObjResult(interp, - Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX)); - break; + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); } - case CONF_UNKNOWN: - Tcl_GetEnsembleUnknownHandler(NULL, token, &resultObj); - if (resultObj != NULL) { - Tcl_SetObjResult(interp, resultObj); - } - break; + mapObj = (patchedDict ? patchedDict : objv[1]); + if (patchedDict) { + allocatedMapFlag = 1; } - } else if (objc == 3) { - /* - * Produce list of all information. - */ + continue; + mapError: + Tcl_DictObjDone(&search); + if (patchedDict) { + Tcl_DecrRefCount(patchedDict); + } + goto error; + } + case CRT_PREFIX: + if (Tcl_GetBooleanFromObj(interp, objv[1], + &permitPrefix) != TCL_OK) { + goto error; + } + continue; + case CRT_UNKNOWN: + if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { + goto 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.) + */ - 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()); + 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); + return token; + error: + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * ReadOneEnsembleOption -- + * + * Core of implementation of "namespace ensemble configure" with just a + * single option name. + * + * Results: + * Tcl result code. Modifies the interpreter result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +static int +ReadOneEnsembleOption( + Tcl_Interp *interp, + Tcl_Command token, /* The ensemble to read from. */ + Tcl_Obj *optionObj) /* The name of the option to read. */ +{ + Tcl_Obj *resultObj = NULL; /* silence gcc 4 warning */ + enum EnsConfigOpts index; + + if (Tcl_GetIndexFromObj(interp, optionObj, ensembleConfigOptions, + "option", 0, &index) != TCL_OK) { + return TCL_ERROR; + } + switch (index) { + case CONF_SUBCMDS: + Tcl_GetEnsembleSubcommandList(NULL, token, &resultObj); + if (resultObj != NULL) { Tcl_SetObjResult(interp, resultObj); - } else { - Tcl_Size len; - int 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, ¶mObj); - Tcl_GetEnsembleUnknownHandler(NULL, token, &unknownObj); - Tcl_GetEnsembleFlags(NULL, token, &flags); - permitPrefix = (flags & TCL_ENSEMBLE_PREFIX) != 0; - - objv += 3; - objc -= 3; + } + 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: { + Tcl_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; + } + return TCL_OK; +} +/* + *---------------------------------------------------------------------- + * + * ReadAllEnsembleOptions -- + * + * Core of implementation of "namespace ensemble configure" without + * option names. + * + * Results: + * Tcl result code. Modifies the interpreter result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +static int +ReadAllEnsembleOptions( + Tcl_Interp *interp, + Tcl_Command token) /* The ensemble to read from. */ +{ + Tcl_Obj *resultObj, *tmpObj = NULL; /* silence gcc 4 warning */ + int flags = 0; /* silence gcc 4 warning */ + Tcl_Namespace *namespacePtr = NULL; /* silence gcc 4 warning */ + + TclNewObj(resultObj); + + /* -map option */ + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewStringObj(ensembleConfigOptions[CONF_MAP], + TCL_AUTO_LENGTH)); + 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], + TCL_AUTO_LENGTH)); + Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr); + Tcl_ListObjAppendElement(NULL, resultObj, NewNsObj(namespacePtr)); + + /* -parameters option */ + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewStringObj(ensembleConfigOptions[CONF_PARAM], + TCL_AUTO_LENGTH)); + 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], + TCL_AUTO_LENGTH)); + 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], + TCL_AUTO_LENGTH)); + 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], + TCL_AUTO_LENGTH)); + Tcl_GetEnsembleUnknownHandler(NULL, token, &tmpObj); + Tcl_ListObjAppendElement(NULL, resultObj, + (tmpObj != NULL) ? tmpObj : Tcl_NewObj()); + + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; +} +/* + *---------------------------------------------------------------------- + * + * SetEnsembleConfigOptions -- + * + * Core of implementation of "namespace ensemble configure" with even + * number of arguments (where there is at least one pair). + * + * Results: + * Tcl result code. Modifies the interpreter result. + * + * Side effects: + * Modifies the ensemble's configuration. + * + *---------------------------------------------------------------------- + */ +static int +SetEnsembleConfigOptions( + Tcl_Interp *interp, + Tcl_Command token, /* The ensemble to configure. */ + int objc, /* The count of option-related arguments. */ + Tcl_Obj *const objv[]) /* Option-related arguments. */ +{ + Tcl_Size len; + int allocatedMapFlag = 0; + Tcl_Obj *subcmdObj = NULL, *mapObj = NULL, *paramObj = NULL, + *unknownObj = NULL; /* Defaults, silence gcc 4 warnings */ + Tcl_Obj *listObj; + Tcl_DictSearch search; + int permitPrefix, flags = 0; /* silence gcc 4 warning */ + enum EnsConfigOpts index; + int done; + + Tcl_GetEnsembleSubcommandList(NULL, token, &subcmdObj); + Tcl_GetEnsembleMappingDict(NULL, token, &mapObj); + Tcl_GetEnsembleParameterList(NULL, token, ¶mObj); + Tcl_GetEnsembleUnknownHandler(NULL, token, &unknownObj); + Tcl_GetEnsembleFlags(NULL, token, &flags); + permitPrefix = (flags & TCL_ENSEMBLE_PREFIX) != 0; + + /* + * 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) { + goto freeMapAndError; + } + switch (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; + Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp); + const char *cmd; /* - * 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. + * Verify that the map is sensible. */ - for (; objc>0 ; objc-=2,objv+=2) { - enum EnsConfigOpts idx; - if (Tcl_GetIndexFromObj(interp, objv[0],ensembleConfigOptions, - "option", 0, &idx) != TCL_OK) { - freeMapAndError: - if (allocatedMapFlag) { - Tcl_DecrRefCount(mapObj); - } - return TCL_ERROR; - } - switch (idx) { - 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; + } else if (done) { + mapObj = NULL; + continue; + } - if (Tcl_DictObjFirst(interp, objv[1], &search, - &subcmdWordsObj, &listObj, &done) != TCL_OK) { - goto freeMapAndError; - } - if (done) { - mapObj = NULL; - continue; - } - do { - if (TclListObjLength(interp, listObj, &len) != 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", (char *)NULL); - Tcl_DictObjDone(&search); - if (patchedDict) { - Tcl_DecrRefCount(patchedDict); - } - goto freeMapAndError; - } - if (TclListObjGetElements(interp, listObj, &len, - &listv) != TCL_OK) { - 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, "::", (char *)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; + do { + if (TclListObjLength(interp, listObj, &len) != TCL_OK) { + goto finishSearchAndError; } - case CONF_NAMESPACE: + if (len < 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "option -namespace is read-only", -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "READ_ONLY", - (char *)NULL); - goto freeMapAndError; - case CONF_PREFIX: - if (Tcl_GetBooleanFromObj(interp, objv[1], - &permitPrefix) != TCL_OK) { - goto freeMapAndError; + "ensemble subcommand implementations " + "must be non-empty lists", TCL_AUTO_LENGTH)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", + "EMPTY_TARGET", (char *)NULL); + goto finishSearchAndError; + } + if (TclListObjGetElements(interp, listObj, &len, + &listv) != TCL_OK) { + goto finishSearchAndError; + } + 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, "::", (char *)NULL); } - continue; - case CONF_UNKNOWN: - if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { - goto freeMapAndError; + Tcl_AppendObjToObj(newCmd, listv[0]); + Tcl_ListObjReplace(NULL, newList, 0, 1, 1, &newCmd); + if (patchedDict == NULL) { + patchedDict = Tcl_DuplicateObj(objv[1]); } - unknownObj = (len > 0 ? objv[1] : NULL); - continue; + 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; - /* - * 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); + finishSearchAndError: + Tcl_DictObjDone(&search); + if (patchedDict) { + Tcl_DecrRefCount(patchedDict); + } + goto freeMapAndError; + } + case CONF_NAMESPACE: + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "option -namespace is read-only", TCL_AUTO_LENGTH)); + Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "READ_ONLY", + (char *)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; } - return TCL_OK; - - default: - Tcl_Panic("unexpected ensemble command"); } + + /* + * 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; + + freeMapAndError: + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + return TCL_ERROR; } /* @@ -684,13 +781,14 @@ TclCreateEnsembleInNs( * in. */ Tcl_Namespace *ensembleNsPtr, /* Name of the namespace for the ensemble. */ - int flags) + int flags) /* Whether we need exact matching and whether + * we bytecode-compile the ensemble's uses. */ { Namespace *nsPtr = (Namespace *) ensembleNsPtr; EnsembleConfig *ensemblePtr; Tcl_Command token; - ensemblePtr = (EnsembleConfig *)Tcl_Alloc(sizeof(EnsembleConfig)); + ensemblePtr = (EnsembleConfig *) Tcl_Alloc(sizeof(EnsembleConfig)); token = TclNRCreateCommandInNs(interp, name, (Tcl_Namespace *) nameNsPtr, TclEnsembleImplementationCmd, NsEnsembleImplementationCmdNR, ensemblePtr, DeleteEnsembleConfig); @@ -744,16 +842,16 @@ TclCreateEnsembleInNs( * Effect * The ensemble is created and marked for compilation. * - * *---------------------------------------------------------------------- */ Tcl_Command Tcl_CreateEnsemble( Tcl_Interp *interp, - const char *name, - Tcl_Namespace *namespacePtr, - int flags) + const char *name, /* The ensemble name. */ + Tcl_Namespace *namespacePtr,/* Context namespace. */ + int flags) /* Whether we need exact matching and whether + * we bytecode-compile the ensemble's uses. */ { Namespace *nsPtr = (Namespace *) namespacePtr, *foundNsPtr, *altNsPtr, *actualNsPtr; @@ -772,6 +870,73 @@ Tcl_CreateEnsemble( /* *---------------------------------------------------------------------- * + * GetEnsembleFromCommand -- + * + * Standard check to see if a command is an ensemble. + * + * Results: + * The ensemble implementation if the command is an ensemble. NULL if it + * isn't. + * + * Side effects: + * Reports an error in the interpreter (if non-NULL) if the command is + * not an ensemble. + * + *---------------------------------------------------------------------- + */ +static inline EnsembleConfig * +GetEnsembleFromCommand( + Tcl_Interp *interp, /* Where to report an error. May be NULL. */ + Tcl_Command token) /* What to check for ensemble-ness. */ +{ + Command *cmdPtr = (Command *) token; + + if (cmdPtr->objProc != TclEnsembleImplementationCmd) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command is not an ensemble", TCL_AUTO_LENGTH)); + Tcl_SetErrorCode(interp, + "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (char *)NULL); + } + return NULL; + } + return (EnsembleConfig *) cmdPtr->objClientData; +} + +/* + *---------------------------------------------------------------------- + * + * BumpEpochIfNecessary -- + * + * Increments the compilation epoch if the (ensemble) command is one where + * changes would be seen by the compiler in some cases. + * + * Results: + * None. + * + * Side effects: + * May trigger later bytecode recompilations. + * + *---------------------------------------------------------------------- + */ +static inline void +BumpEpochIfNecessary( + Tcl_Interp *interp, + Tcl_Command token) /* The ensemble command to check. */ +{ + /* + * Special hack to make compiling of [info exists] work when the + * dictionary is modified. + */ + + if (((Command *) token)->compileProc != NULL) { + ((Interp *) interp)->compileEpoch++; + } +} + +/* + *---------------------------------------------------------------------- + * * Tcl_SetEnsembleSubcommandList -- * * Set the subcommand list for a particular ensemble. @@ -789,17 +954,13 @@ Tcl_CreateEnsemble( int Tcl_SetEnsembleSubcommandList( Tcl_Interp *interp, - Tcl_Command token, + Tcl_Command token, /* The ensemble command to write to. */ Tcl_Obj *subcmdList) { - Command *cmdPtr = (Command *) token; - EnsembleConfig *ensemblePtr; + EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token); Tcl_Obj *oldList; - if (cmdPtr->objProc != TclEnsembleImplementationCmd) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "command is not an ensemble", -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (char *)NULL); + if (ensemblePtr == NULL) { return TCL_ERROR; } if (subcmdList != NULL) { @@ -813,7 +974,6 @@ Tcl_SetEnsembleSubcommandList( } } - ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData; oldList = ensemblePtr->subcmdList; ensemblePtr->subcmdList = subcmdList; if (subcmdList != NULL) { @@ -831,16 +991,7 @@ Tcl_SetEnsembleSubcommandList( */ ensemblePtr->nsPtr->exportLookupEpoch++; - - /* - * Special hack to make compiling of [info exists] work when the - * dictionary is modified. - */ - - if (cmdPtr->compileProc != NULL) { - ((Interp *) interp)->compileEpoch++; - } - + BumpEpochIfNecessary(interp, token); return TCL_OK; } @@ -864,18 +1015,14 @@ Tcl_SetEnsembleSubcommandList( int Tcl_SetEnsembleParameterList( Tcl_Interp *interp, - Tcl_Command token, + Tcl_Command token, /* The ensemble command to write to. */ Tcl_Obj *paramList) { - Command *cmdPtr = (Command *) token; - EnsembleConfig *ensemblePtr; + EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token); Tcl_Obj *oldList; Tcl_Size length; - if (cmdPtr->objProc != TclEnsembleImplementationCmd) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "command is not an ensemble", -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (char *)NULL); + if (ensemblePtr == NULL) { return TCL_ERROR; } if (paramList == NULL) { @@ -889,7 +1036,6 @@ Tcl_SetEnsembleParameterList( } } - ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData; oldList = ensemblePtr->parameterList; ensemblePtr->parameterList = paramList; if (paramList != NULL) { @@ -908,16 +1054,7 @@ Tcl_SetEnsembleParameterList( */ ensemblePtr->nsPtr->exportLookupEpoch++; - - /* - * Special hack to make compiling of [info exists] work when the - * dictionary is modified. - */ - - if (cmdPtr->compileProc != NULL) { - ((Interp *) interp)->compileEpoch++; - } - + BumpEpochIfNecessary(interp, token); return TCL_OK; } @@ -941,17 +1078,13 @@ Tcl_SetEnsembleParameterList( int Tcl_SetEnsembleMappingDict( Tcl_Interp *interp, - Tcl_Command token, + Tcl_Command token, /* The ensemble command to write to. */ Tcl_Obj *mapDict) { - Command *cmdPtr = (Command *) token; - EnsembleConfig *ensemblePtr; + EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token); Tcl_Obj *oldDict; - if (cmdPtr->objProc != TclEnsembleImplementationCmd) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "command is not an ensemble", -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (char *)NULL); + if (ensemblePtr == NULL) { return TCL_ERROR; } if (mapDict != NULL) { @@ -977,7 +1110,7 @@ Tcl_SetEnsembleMappingDict( if (bytes[0] != ':' || bytes[1] != ':') { Tcl_SetObjResult(interp, Tcl_NewStringObj( "ensemble target is not a fully-qualified command", - -1)); + TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "UNQUALIFIED_TARGET", (char *)NULL); Tcl_DictObjDone(&search); @@ -990,7 +1123,6 @@ Tcl_SetEnsembleMappingDict( } } - ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData; oldDict = ensemblePtr->subcommandDict; ensemblePtr->subcommandDict = mapDict; if (mapDict != NULL) { @@ -1008,16 +1140,7 @@ Tcl_SetEnsembleMappingDict( */ ensemblePtr->nsPtr->exportLookupEpoch++; - - /* - * Special hack to make compiling of [info exists] work when the - * dictionary is modified. - */ - - if (cmdPtr->compileProc != NULL) { - ((Interp *) interp)->compileEpoch++; - } - + BumpEpochIfNecessary(interp, token); return TCL_OK; } @@ -1041,17 +1164,13 @@ Tcl_SetEnsembleMappingDict( int Tcl_SetEnsembleUnknownHandler( Tcl_Interp *interp, - Tcl_Command token, + Tcl_Command token, /* The ensemble command to write to. */ Tcl_Obj *unknownList) { - Command *cmdPtr = (Command *) token; - EnsembleConfig *ensemblePtr; + EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token); Tcl_Obj *oldList; - if (cmdPtr->objProc != TclEnsembleImplementationCmd) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "command is not an ensemble", -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (char *)NULL); + if (ensemblePtr == NULL) { return TCL_ERROR; } if (unknownList != NULL) { @@ -1065,7 +1184,6 @@ Tcl_SetEnsembleUnknownHandler( } } - ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData; oldList = ensemblePtr->unknownHandler; ensemblePtr->unknownHandler = unknownList; if (unknownList != NULL) { @@ -1107,23 +1225,16 @@ Tcl_SetEnsembleUnknownHandler( int Tcl_SetEnsembleFlags( Tcl_Interp *interp, - Tcl_Command token, + Tcl_Command token, /* The ensemble command to write to. */ int flags) { - Command *cmdPtr = (Command *) token; - EnsembleConfig *ensemblePtr; - int wasCompiled; + EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token); + int changedFlags = flags ^ ensemblePtr->flags; - if (cmdPtr->objProc != TclEnsembleImplementationCmd) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "command is not an ensemble", -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (char *)NULL); + if (ensemblePtr == NULL) { return TCL_ERROR; } - ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData; - wasCompiled = ensemblePtr->flags & ENSEMBLE_COMPILE; - /* * This API refuses to set the ENSEMBLE_DEAD flag... */ @@ -1146,16 +1257,10 @@ Tcl_SetEnsembleFlags( * 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++; - } + if (changedFlags & ENSEMBLE_COMPILE) { + ((Command*) ensemblePtr->token)->compileProc = + ((flags & ENSEMBLE_COMPILE) ? TclCompileEnsemble : NULL); + ((Interp *) interp)->compileEpoch++; } return TCL_OK; @@ -1184,22 +1289,14 @@ Tcl_SetEnsembleFlags( int Tcl_GetEnsembleSubcommandList( Tcl_Interp *interp, - Tcl_Command token, + Tcl_Command token, /* The ensemble command to read from. */ Tcl_Obj **subcmdListPtr) { - Command *cmdPtr = (Command *) token; - EnsembleConfig *ensemblePtr; + EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token); - if (cmdPtr->objProc != TclEnsembleImplementationCmd) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "command is not an ensemble", -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (char *)NULL); - } + if (ensemblePtr == NULL) { return TCL_ERROR; } - - ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData; *subcmdListPtr = ensemblePtr->subcmdList; return TCL_OK; } @@ -1226,22 +1323,14 @@ Tcl_GetEnsembleSubcommandList( int Tcl_GetEnsembleParameterList( Tcl_Interp *interp, - Tcl_Command token, + Tcl_Command token, /* The ensemble command to read from. */ Tcl_Obj **paramListPtr) { - Command *cmdPtr = (Command *) token; - EnsembleConfig *ensemblePtr; + EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token); - if (cmdPtr->objProc != TclEnsembleImplementationCmd) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "command is not an ensemble", -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (char *)NULL); - } + if (ensemblePtr == NULL) { return TCL_ERROR; } - - ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData; *paramListPtr = ensemblePtr->parameterList; return TCL_OK; } @@ -1268,22 +1357,14 @@ Tcl_GetEnsembleParameterList( int Tcl_GetEnsembleMappingDict( Tcl_Interp *interp, - Tcl_Command token, + Tcl_Command token, /* The ensemble command to read from. */ Tcl_Obj **mapDictPtr) { - Command *cmdPtr = (Command *) token; - EnsembleConfig *ensemblePtr; + EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token); - if (cmdPtr->objProc != TclEnsembleImplementationCmd) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "command is not an ensemble", -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (char *)NULL); - } + if (ensemblePtr == NULL) { return TCL_ERROR; } - - ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData; *mapDictPtr = ensemblePtr->subcommandDict; return TCL_OK; } @@ -1309,22 +1390,14 @@ Tcl_GetEnsembleMappingDict( int Tcl_GetEnsembleUnknownHandler( Tcl_Interp *interp, - Tcl_Command token, + Tcl_Command token, /* The ensemble command to read from. */ Tcl_Obj **unknownListPtr) { - Command *cmdPtr = (Command *) token; - EnsembleConfig *ensemblePtr; + EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token); - if (cmdPtr->objProc != TclEnsembleImplementationCmd) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "command is not an ensemble", -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (char *)NULL); - } + if (ensemblePtr == NULL) { return TCL_ERROR; } - - ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData; *unknownListPtr = ensemblePtr->unknownHandler; return TCL_OK; } @@ -1350,22 +1423,14 @@ Tcl_GetEnsembleUnknownHandler( int Tcl_GetEnsembleFlags( Tcl_Interp *interp, - Tcl_Command token, + Tcl_Command token, /* The ensemble command to read from. */ int *flagsPtr) { - Command *cmdPtr = (Command *) token; - EnsembleConfig *ensemblePtr; + EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token); - if (cmdPtr->objProc != TclEnsembleImplementationCmd) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "command is not an ensemble", -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (char *)NULL); - } + if (ensemblePtr == NULL) { return TCL_ERROR; } - - ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData; *flagsPtr = ensemblePtr->flags; return TCL_OK; } @@ -1391,22 +1456,14 @@ Tcl_GetEnsembleFlags( int Tcl_GetEnsembleNamespace( Tcl_Interp *interp, - Tcl_Command token, + Tcl_Command token, /* The ensemble command to read from. */ Tcl_Namespace **namespacePtrPtr) { - Command *cmdPtr = (Command *) token; - EnsembleConfig *ensemblePtr; + EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token); - if (cmdPtr->objProc != TclEnsembleImplementationCmd) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "command is not an ensemble", -1)); - Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", (char *)NULL); - } + if (ensemblePtr == NULL) { return TCL_ERROR; } - - ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData; *namespacePtrPtr = (Tcl_Namespace *) ensemblePtr->nsPtr; return TCL_OK; } @@ -1439,24 +1496,23 @@ Tcl_FindEnsemble( int flags) /* Either 0 or TCL_LEAVE_ERR_MSG; other flags * are probably not useful. */ { - Command *cmdPtr; + Tcl_Command token; - cmdPtr = (Command *) - Tcl_FindCommand(interp, TclGetString(cmdNameObj), NULL, flags); - if (cmdPtr == NULL) { + token = Tcl_FindCommand(interp, TclGetString(cmdNameObj), NULL, flags); + if (token == NULL) { return NULL; } - if (cmdPtr->objProc != TclEnsembleImplementationCmd) { + if (((Command *) token)->objProc != TclEnsembleImplementationCmd) { /* * Reuse existing infrastructure for following import link chains * rather than duplicating it. */ - cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); + token = TclGetOriginalCommand(token); - if (cmdPtr == NULL - || cmdPtr->objProc != TclEnsembleImplementationCmd) { + if (token == NULL || + ((Command *) token)->objProc != TclEnsembleImplementationCmd) { if (flags & TCL_LEAVE_ERR_MSG) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" is not an ensemble command", @@ -1468,7 +1524,7 @@ Tcl_FindEnsemble( } } - return (Tcl_Command) cmdPtr; + return token; } /* @@ -1490,7 +1546,7 @@ Tcl_FindEnsemble( int Tcl_IsEnsemble( - Tcl_Command token) + Tcl_Command token) /* The command to check. */ { Command *cmdPtr = (Command *) token; @@ -1519,6 +1575,11 @@ Tcl_IsEnsemble( * Currently, the TCL_ENSEMBLE_PREFIX ensemble flag is only used on * top-level ensemble commands. * + * This code is not safe to run in Safe interpreter after user code has + * executed. That's OK right now because it's just used to set up Tcl, + * but it means we mustn't expose it at all, not even to Tk (until we can + * hide commands in namespaces directly). + * * Results: * Handle for the new ensemble, or NULL on failure. * @@ -1531,8 +1592,8 @@ Tcl_IsEnsemble( Tcl_Command TclMakeEnsemble( Tcl_Interp *interp, - const char *name, /* The ensemble name (as explained above) */ - const EnsembleImplMap map[]) /* The subcommands to create */ + const char *name, /* The ensemble name (as explained above) */ + const EnsembleImplMap map[])/* The subcommands to create */ { Tcl_Command ensemble; Tcl_Namespace *ns; @@ -1549,7 +1610,7 @@ TclMakeEnsemble( Tcl_DStringInit(&buf); Tcl_DStringInit(&hiddenBuf); TclDStringAppendLiteral(&hiddenBuf, "tcl:"); - Tcl_DStringAppend(&hiddenBuf, name, -1); + Tcl_DStringAppend(&hiddenBuf, name, TCL_AUTO_LENGTH); TclDStringAppendLiteral(&hiddenBuf, ":"); hiddenLen = Tcl_DStringLength(&hiddenBuf); if (name[0] == ':' && name[1] == ':') { @@ -1558,7 +1619,7 @@ TclMakeEnsemble( */ cmdName = name; - Tcl_DStringAppend(&buf, name, -1); + Tcl_DStringAppend(&buf, name, TCL_AUTO_LENGTH); ensembleFlags = TCL_ENSEMBLE_PREFIX; } else { /* @@ -1574,7 +1635,7 @@ TclMakeEnsemble( for (i = 0; i < nameCount; ++i) { TclDStringAppendLiteral(&buf, "::"); - Tcl_DStringAppend(&buf, nameParts[i], -1); + Tcl_DStringAppend(&buf, nameParts[i], TCL_AUTO_LENGTH); } } @@ -1621,7 +1682,7 @@ TclMakeEnsemble( for (i=0 ; map[i].name != NULL ; i++) { TclNewStringObj(toObj, Tcl_DStringValue(&buf), Tcl_DStringLength(&buf)); - Tcl_AppendToObj(toObj, map[i].name, -1); + Tcl_AppendToObj(toObj, map[i].name, TCL_AUTO_LENGTH); TclDictPut(NULL, mapDict, map[i].name, toObj); if (map[i].proc || map[i].nreProc) { @@ -1639,7 +1700,8 @@ TclMakeEnsemble( map[i].nreProc, map[i].clientData, NULL); Tcl_DStringSetLength(&hiddenBuf, hiddenLen); if (Tcl_HideCommand(interp, "___tmp", - Tcl_DStringAppend(&hiddenBuf, map[i].name, -1))) { + Tcl_DStringAppend(&hiddenBuf, map[i].name, + TCL_AUTO_LENGTH))) { Tcl_Panic("%s", Tcl_GetStringResult(interp)); } } else { @@ -1701,12 +1763,12 @@ TclEnsembleImplementationCmd( static int NsEnsembleImplementationCmdNR( - void *clientData, + void *clientData, /* The ensemble this is the impl. of. */ Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { - EnsembleConfig *ensemblePtr = (EnsembleConfig *)clientData; + EnsembleConfig *ensemblePtr = (EnsembleConfig *) clientData; /* The ensemble itself. */ Tcl_Obj *prefixObj; /* An object containing the prefix words of * the command that implements the @@ -1735,8 +1797,7 @@ NsEnsembleImplementationCmdNR( Tcl_DStringInit(&buf); if (ensemblePtr->parameterList) { - Tcl_DStringAppend(&buf, - TclGetString(ensemblePtr->parameterList), -1); + TclDStringAppendObj(&buf, ensemblePtr->parameterList); TclDStringAppendLiteral(&buf, " "); } TclDStringAppendLiteral(&buf, "subcommand ?arg ...?"); @@ -1753,7 +1814,8 @@ NsEnsembleImplementationCmdNR( if (!Tcl_InterpDeleted(interp)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "ensemble activated for deleted namespace", -1)); + "ensemble activated for deleted namespace", + TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "DEAD", (char *)NULL); } return TCL_ERROR; @@ -1776,8 +1838,8 @@ NsEnsembleImplementationCmdNR( ECRGetInternalRep(subObj, ensembleCmd); if (ensembleCmd) { if (ensembleCmd->epoch == ensemblePtr->epoch && - ensembleCmd->token == (Command *)ensemblePtr->token) { - prefixObj = (Tcl_Obj *)Tcl_GetHashValue(ensembleCmd->hPtr); + ensembleCmd->token == (Command *) ensemblePtr->token) { + prefixObj = (Tcl_Obj *) Tcl_GetHashValue(ensembleCmd->hPtr); Tcl_IncrRefCount(prefixObj); if (ensembleCmd->fix) { TclSpellFix(interp, objv, objc, subIdx, subObj, ensembleCmd->fix); @@ -1798,7 +1860,6 @@ NsEnsembleImplementationCmdNR( hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable, TclGetString(subObj)); if (hPtr != NULL) { - /* * Cache ensemble in the subcommand object for later. */ @@ -1867,7 +1928,7 @@ NsEnsembleImplementationCmdNR( * Record the spelling correction for usage message. */ - fix = Tcl_NewStringObj(fullName, -1); + fix = Tcl_NewStringObj(fullName, TCL_AUTO_LENGTH); /* * Cache for later in the subcommand object. @@ -1877,7 +1938,7 @@ NsEnsembleImplementationCmdNR( TclSpellFix(interp, objv, objc, subIdx, subObj, fix); } - prefixObj = (Tcl_Obj *)Tcl_GetHashValue(hPtr); + prefixObj = (Tcl_Obj *) Tcl_GetHashValue(hPtr); Tcl_IncrRefCount(prefixObj); runResultingSubcommand: @@ -1934,7 +1995,7 @@ NsEnsembleImplementationCmdNR( TclSkipTailcall(interp); TclListObjGetElements(NULL, copyPtr, ©Objc, ©Objv); - ((Interp *)interp)->lookupNsPtr = ensemblePtr->nsPtr; + ((Interp *) interp)->lookupNsPtr = ensemblePtr->nsPtr; return TclNREvalObjv(interp, copyObjc, copyObjv, TCL_EVAL_INVOKE, NULL); } @@ -1978,12 +2039,14 @@ NsEnsembleImplementationCmdNR( (ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? " or ambiguous" : ""), TclGetString(subObj)); if (ensemblePtr->subcommandTable.numEntries == 1) { - Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[0], -1); + Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[0], + TCL_AUTO_LENGTH); } else { Tcl_Size i; for (i=0 ; i<ensemblePtr->subcommandTable.numEntries-1 ; i++) { - Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[i], -1); + Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[i], + TCL_AUTO_LENGTH); Tcl_AppendToObj(errorObj, ", ", 2); } Tcl_AppendPrintfToObj(errorObj, "or %s", @@ -2184,9 +2247,9 @@ TclSpellFix( if (search[0] == NULL) { store = (Tcl_Obj **) search[2]; } else { - Tcl_Obj **tmp = (Tcl_Obj **)Tcl_Alloc(3 * sizeof(Tcl_Obj *)); + Tcl_Obj **tmp = (Tcl_Obj **) Tcl_Alloc(3 * sizeof(Tcl_Obj *)); - store = (Tcl_Obj **)Tcl_Alloc(size * sizeof(Tcl_Obj *)); + store = (Tcl_Obj **) Tcl_Alloc(size * sizeof(Tcl_Obj *)); memcpy(store, iPtr->ensembleRewrite.sourceObjs, size * sizeof(Tcl_Obj *)); @@ -2209,14 +2272,25 @@ TclSpellFix( TclNRAddCallback(interp, TclNRReleaseValues, fix, NULL, NULL, NULL); } +/* + *---------------------------------------------------------------------- + * + * TclEnsembleGetRewriteValues -- + * + * Get the original arguments to the current command before any rewrite + * rules (from aliases, ensembles, and method forwards) were applied. + * + *---------------------------------------------------------------------- + */ Tcl_Obj *const * TclEnsembleGetRewriteValues( Tcl_Interp *interp) /* Current interpreter. */ { Interp *iPtr = (Interp *) interp; Tcl_Obj *const *origObjv = iPtr->ensembleRewrite.sourceObjs; + if (origObjv[0] == NULL) { - origObjv = (Tcl_Obj *const *)origObjv[2]; + origObjv = (Tcl_Obj *const *) origObjv[2]; } return origObjv; } @@ -2237,7 +2311,6 @@ TclEnsembleGetRewriteValues( * *---------------------------------------------------------------------- */ - Tcl_Obj *const * TclFetchEnsembleRoot( Tcl_Interp *interp, @@ -2252,7 +2325,7 @@ TclFetchEnsembleRoot( *objcPtr = objc + iPtr->ensembleRewrite.numRemovedObjs - iPtr->ensembleRewrite.numInsertedObjs; if (iPtr->ensembleRewrite.sourceObjs[0] == NULL) { - sourceObjs = (Tcl_Obj *const *)iPtr->ensembleRewrite.sourceObjs[1]; + sourceObjs = (Tcl_Obj *const *) iPtr->ensembleRewrite.sourceObjs[1]; } else { sourceObjs = iPtr->ensembleRewrite.sourceObjs; } @@ -2288,10 +2361,12 @@ TclFetchEnsembleRoot( static inline int EnsembleUnknownCallback( Tcl_Interp *interp, - EnsembleConfig *ensemblePtr, - int objc, - Tcl_Obj *const objv[], - Tcl_Obj **prefixObjPtr) + EnsembleConfig *ensemblePtr,/* The ensemble structure. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[], /* Actual arguments. */ + Tcl_Obj **prefixObjPtr) /* Where to write the prefix suggested by the + * unknown callback. Must not be NULL. Only has + * a meaningful value on TCL_OK. */ { Tcl_Size paramc; int result; @@ -2324,7 +2399,8 @@ EnsembleUnknownCallback( if ((result == TCL_OK) && (ensemblePtr->flags & ENSEMBLE_DEAD)) { if (!Tcl_InterpDeleted(interp)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "unknown subcommand handler deleted its ensemble", -1)); + "unknown subcommand handler deleted its ensemble", + TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "UNKNOWN_DELETED", (char *)NULL); } @@ -2372,16 +2448,20 @@ EnsembleUnknownCallback( if (result != TCL_ERROR) { Tcl_ResetResult(interp); Tcl_SetObjResult(interp, Tcl_NewStringObj( - "unknown subcommand handler returned bad code: ", -1)); + "unknown subcommand handler returned bad code: ", + TCL_AUTO_LENGTH)); switch (result) { case TCL_RETURN: - Tcl_AppendToObj(Tcl_GetObjResult(interp), "return", -1); + Tcl_AppendToObj(Tcl_GetObjResult(interp), "return", + TCL_AUTO_LENGTH); break; case TCL_BREAK: - Tcl_AppendToObj(Tcl_GetObjResult(interp), "break", -1); + Tcl_AppendToObj(Tcl_GetObjResult(interp), "break", + TCL_AUTO_LENGTH); break; case TCL_CONTINUE: - Tcl_AppendToObj(Tcl_GetObjResult(interp), "continue", -1); + Tcl_AppendToObj(Tcl_GetObjResult(interp), "continue", + TCL_AUTO_LENGTH); break; default: Tcl_AppendPrintfToObj(Tcl_GetObjResult(interp), "%d", result); @@ -2421,10 +2501,11 @@ EnsembleUnknownCallback( static void MakeCachedEnsembleCommand( - Tcl_Obj *objPtr, - EnsembleConfig *ensemblePtr, - Tcl_HashEntry *hPtr, - Tcl_Obj *fix) + Tcl_Obj *objPtr, /* Object to cache in. */ + EnsembleConfig *ensemblePtr,/* Ensemble implementation. */ + Tcl_HashEntry *hPtr, /* What to cache; what the object maps to. */ + Tcl_Obj *fix) /* Spelling correction for later error, or NULL + * if no correction. */ { EnsembleCmdRep *ensembleCmd; @@ -2439,7 +2520,7 @@ MakeCachedEnsembleCommand( * Replace any old internal representation with a new one. */ - ensembleCmd = (EnsembleCmdRep *)Tcl_Alloc(sizeof(EnsembleCmdRep)); + ensembleCmd = (EnsembleCmdRep *) Tcl_Alloc(sizeof(EnsembleCmdRep)); ECRSetInternalRep(objPtr, ensembleCmd); } @@ -2478,29 +2559,29 @@ MakeCachedEnsembleCommand( static void ClearTable( - EnsembleConfig *ensemblePtr) + EnsembleConfig *ensemblePtr)/* Ensemble to clear table of. */ { Tcl_HashTable *hash = &ensemblePtr->subcommandTable; if (hash->numEntries != 0) { - Tcl_HashSearch search; - Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(hash, &search); + Tcl_HashSearch search; + Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(hash, &search); - while (hPtr != NULL) { - Tcl_Obj *prefixObj = (Tcl_Obj *)Tcl_GetHashValue(hPtr); - Tcl_DecrRefCount(prefixObj); - hPtr = Tcl_NextHashEntry(&search); - } - Tcl_Free(ensemblePtr->subcommandArrayPtr); + while (hPtr != NULL) { + Tcl_Obj *prefixObj = (Tcl_Obj *) Tcl_GetHashValue(hPtr); + Tcl_DecrRefCount(prefixObj); + hPtr = Tcl_NextHashEntry(&search); + } + Tcl_Free(ensemblePtr->subcommandArrayPtr); } Tcl_DeleteHashTable(hash); } static void DeleteEnsembleConfig( - void *clientData) + void *clientData) /* Ensemble to delete. */ { - EnsembleConfig *ensemblePtr = (EnsembleConfig *)clientData; + EnsembleConfig *ensemblePtr = (EnsembleConfig *) clientData; Namespace *nsPtr = ensemblePtr->nsPtr; /* Unlink from the ensemble chain if it not already marked as unlinked. */ @@ -2579,7 +2660,7 @@ DeleteEnsembleConfig( static void BuildEnsembleConfig( - EnsembleConfig *ensemblePtr) + EnsembleConfig *ensemblePtr)/* Ensemble to set up. */ { Tcl_HashSearch search; /* Used for scanning the commands in * the namespace for this ensemble. */ @@ -2594,100 +2675,100 @@ BuildEnsembleConfig( Tcl_InitHashTable(hash, TCL_STRING_KEYS); if (subList) { - Tcl_Size subc; - Tcl_Obj **subv, *target, *cmdObj, *cmdPrefixObj; - const char *name; - - /* - * There is a list of exactly what subcommands go in the table. - * Determine the target for each. - */ - - TclListObjGetElements(NULL, subList, &subc, &subv); - if (subList == mapDict) { - /* - * Unusual 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 { - /* + Tcl_Size subc; + Tcl_Obj **subv, *target, *cmdObj, *cmdPrefixObj; + const char *name; + + /* + * There is a list of exactly what subcommands go in the table. + * Determine the target for each. + */ + + TclListObjGetElements(NULL, subList, &subc, &subv); + if (subList == mapDict) { + /* + * Unusual 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, TCL_AUTO_LENGTH); + 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; - } + 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. Map onto the namespace. - * In this case there is no guarantee that the command - * is actually there. It is the responsibility of the - * programmer (or [::unknown] of course) to provide the procedure. - */ - - cmdObj = Tcl_NewStringObj(name, -1); - cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); - Tcl_SetHashValue(hPtr, cmdPrefixObj); - Tcl_IncrRefCount(cmdPrefixObj); - } - } + 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. Map onto the namespace. + * In this case there is no guarantee that the command is + * actually there. It is the responsibility of the programmer + * (or [::unknown] of course) to provide the procedure. + */ + + cmdObj = Tcl_NewStringObj(name, TCL_AUTO_LENGTH); + cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); + Tcl_SetHashValue(hPtr, cmdPrefixObj); + Tcl_IncrRefCount(cmdPrefixObj); + } + } } else if (mapDict) { - /* - * No subcmd list, but there is a mapping dictionary, so - * use the keys of that. Convert the contents of the dictionary into the - * form required for the internal hashtable of the ensemble. - */ - - Tcl_DictSearch dictSearch; - Tcl_Obj *keyObj, *valueObj; - int done; - - Tcl_DictObjFirst(NULL, ensemblePtr->subcommandDict, &dictSearch, - &keyObj, &valueObj, &done); - while (!done) { - const char *name = TclGetString(keyObj); - - hPtr = Tcl_CreateHashEntry(hash, name, &isNew); - Tcl_SetHashValue(hPtr, valueObj); - Tcl_IncrRefCount(valueObj); - Tcl_DictObjNext(&dictSearch, &keyObj, &valueObj, &done); - } + /* + * No subcmd list, but there is a mapping dictionary, so use + * the keys of that. Convert the contents of the dictionary into the + * form required for the internal hashtable of the ensemble. + */ + + Tcl_DictSearch dictSearch; + Tcl_Obj *keyObj, *valueObj; + int done; + + Tcl_DictObjFirst(NULL, ensemblePtr->subcommandDict, &dictSearch, + &keyObj, &valueObj, &done); + while (!done) { + const char *name = TclGetString(keyObj); + + hPtr = Tcl_CreateHashEntry(hash, name, &isNew); + Tcl_SetHashValue(hPtr, valueObj); + Tcl_IncrRefCount(valueObj); + Tcl_DictObjNext(&dictSearch, &keyObj, &valueObj, &done); + } } else { /* * Use the array of patterns and the hash table whose keys are the @@ -2703,8 +2784,8 @@ BuildEnsembleConfig( hPtr = Tcl_FirstHashEntry(&ensemblePtr->nsPtr->cmdTable, &search); for (; hPtr!= NULL ; hPtr=Tcl_NextHashEntry(&search)) { - char *nsCmdName = /* Name of command in namespace. */ - (char *)Tcl_GetHashKey(&ensemblePtr->nsPtr->cmdTable, hPtr); + char *nsCmdName = (char *) /* Name of command in namespace. */ + Tcl_GetHashKey(&ensemblePtr->nsPtr->cmdTable, hPtr); for (i=0 ; i<ensemblePtr->nsPtr->numExportPatterns ; i++) { if (Tcl_StringMatch(nsCmdName, @@ -2752,8 +2833,8 @@ BuildEnsembleConfig( * the hash too, and vice versa, and run quicksort over the array. */ - ensemblePtr->subcommandArrayPtr = - (char **)Tcl_Alloc(sizeof(char *) * hash->numEntries); + ensemblePtr->subcommandArrayPtr = (char **) + Tcl_Alloc(sizeof(char *) * hash->numEntries); /* * Fill the array from both ends as this reduces the likelihood of @@ -2777,12 +2858,14 @@ BuildEnsembleConfig( j = hash->numEntries; hPtr = Tcl_FirstHashEntry(hash, &search); while (hPtr != NULL) { - ensemblePtr->subcommandArrayPtr[i++] = (char *)Tcl_GetHashKey(hash, hPtr); + ensemblePtr->subcommandArrayPtr[i++] = (char *) + Tcl_GetHashKey(hash, hPtr); hPtr = Tcl_NextHashEntry(&search); if (hPtr == NULL) { break; } - ensemblePtr->subcommandArrayPtr[--j] = (char *)Tcl_GetHashKey(hash, hPtr); + ensemblePtr->subcommandArrayPtr[--j] = (char *) + Tcl_GetHashKey(hash, hPtr); hPtr = Tcl_NextHashEntry(&search); } if (hash->numEntries > 1) { @@ -2796,7 +2879,8 @@ BuildEnsembleConfig( * * NsEnsembleStringOrder -- * - * Helper to for uset with sort() that compares two string pointers. + * Helper to for use with qsort() that compares two array entries that + * contain string pointers. * * Results: * -1 if the first string is smaller, 1 if the second string is smaller, @@ -2810,8 +2894,8 @@ BuildEnsembleConfig( static int NsEnsembleStringOrder( - const void *strPtr1, - const void *strPtr2) + const void *strPtr1, /* Points to first array entry */ + const void *strPtr2) /* Points to second array entry */ { return strcmp(*(const char **)strPtr1, *(const char **)strPtr2); } @@ -2873,7 +2957,8 @@ DupEnsembleCmdRep( Tcl_Obj *copyPtr) { EnsembleCmdRep *ensembleCmd; - EnsembleCmdRep *ensembleCopy = (EnsembleCmdRep *)Tcl_Alloc(sizeof(EnsembleCmdRep)); + EnsembleCmdRep *ensembleCopy = (EnsembleCmdRep *) + Tcl_Alloc(sizeof(EnsembleCmdRep)); ECRGetInternalRep(objPtr, ensembleCmd); ECRSetInternalRep(copyPtr, ensembleCopy); @@ -3140,7 +3225,7 @@ TclCompileEnsemble( 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) { + || ((Interp *) interp)->flags & DONT_COMPILE_CMDS_INLINE) { /* * Maps to an undefined command or a command without a compiler. * Cannot compile. @@ -3192,9 +3277,9 @@ TclCompileEnsemble( */ while (mapPtr->nuloc > eclIndex + 1) { - mapPtr->nuloc--; - Tcl_Free(mapPtr->loc[mapPtr->nuloc].line); - mapPtr->loc[mapPtr->nuloc].line = NULL; + mapPtr->nuloc--; + Tcl_Free(mapPtr->loc[mapPtr->nuloc].line); + mapPtr->loc[mapPtr->nuloc].line = NULL; } /* @@ -3408,7 +3493,7 @@ CompileToInvokedCommand( for (i = 0, tokPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++, tokPtr = TokenAfter(tokPtr)) { if (i > 0 && i <= numWords) { - bytes = TclGetStringFromObj(words[i-1], &length); + bytes = TclGetStringFromObj(words[i - 1], &length); PushLiteral(envPtr, bytes, length); continue; } @@ -3450,7 +3535,8 @@ CompileToInvokedCommand( * Do the replacing dispatch. */ - TclEmitInvoke(envPtr, INST_INVOKE_REPLACE, parsePtr->numWords,numWords+1); + TclEmitInvoke(envPtr, INST_INVOKE_REPLACE, parsePtr->numWords, + numWords + 1); } /* diff --git a/generic/tclInt.h b/generic/tclInt.h index 7a10bda..7f0e842 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2166,7 +2166,8 @@ typedef struct Interp { * processing an ensemble. */ Tcl_Size numRemovedObjs;/* How many arguments have been stripped off * because of ensemble processing. */ - Tcl_Size numInsertedObjs;/* How many of the current arguments were + Tcl_Size numInsertedObjs; + /* How many of the current arguments were * inserted by an ensemble. */ } ensembleRewrite; |