From 8a89716dac2727645108dbd4c88d9cdd9983ac24 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 16 Jun 2024 13:39:51 +0000 Subject: Cleaner ensemble innards --- generic/tclEnsemble.c | 1463 ++++++++++++++++++++++++------------------------- 1 file changed, 731 insertions(+), 732 deletions(-) diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 64f0733..711d59d 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); @@ -84,7 +93,7 @@ static const Tcl_ObjType ensembleCmdType = { NULL /* setFromAnyProc */ }; -#define ECRSetInternalRep(objPtr, ecRepPtr) \ +#define ECRSetInternalRep(objPtr, ecRepPtr) \ do { \ Tcl_ObjInternalRep ir; \ ir.twoPtrValue.ptr1 = (ecRepPtr); \ @@ -92,11 +101,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) /* @@ -105,14 +115,14 @@ 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; static inline Tcl_Obj * @@ -124,7 +134,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,20 +167,15 @@ TclNamespaceEnsembleCmd( Tcl_Obj *const objv[]) { Tcl_Namespace *namespacePtr; - Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp), *cxtPtr, - *foundNsPtr, *altFoundNsPtr, *actualCxtPtr; + Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp); Tcl_Command token; - Tcl_DictSearch search; - Tcl_Obj *listObj; - const char *simpleName; int 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; @@ -186,19 +191,7 @@ TclNamespaceEnsembleCmd( } switch ((enum EnsSubcmds) 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] */ @@ -207,168 +200,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) { - 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", (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 @@ -378,7 +214,6 @@ TclNamespaceEnsembleCmd( Tcl_ResetResult(interp); Tcl_GetCommandFullName(interp, token, Tcl_GetObjResult(interp)); return TCL_OK; - } case ENS_EXISTS: if (objc != 3) { @@ -401,264 +236,450 @@ TclNamespaceEnsembleCmd( } if (objc == 4) { - 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, &index) != TCL_OK) { - return TCL_ERROR; + default: + Tcl_Panic("unexpected ensemble command"); + } + return TCL_OK; +} + +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; + int index; + Tcl_Command token; + 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 ((enum EnsCreateOpts) 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 ((enum EnsConfigOpts) index) { - 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.) + */ + + 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; - 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()); + error: + if (allocatedMapFlag) { + Tcl_DecrRefCount(mapObj); + } + return NULL; +} +static int +ReadOneEnsembleOption( + Tcl_Interp *interp, + Tcl_Command token, /* The ensemble. */ + Tcl_Obj *optionObj) /* The name of the option to read. */ +{ + Tcl_Obj *resultObj = NULL; /* silence gcc 4 warning */ + int index; + + if (Tcl_GetIndexFromObj(interp, optionObj, 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); - } 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; +} + +static int +ReadAllEnsembleOptions( + Tcl_Interp *interp, + Tcl_Command token) /* The ensemble. */ +{ + 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; +} + +static int +SetEnsembleConfigOptions( + Tcl_Interp *interp, + Tcl_Command token, /* The ensemble. */ + 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 */ + int index, 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 ((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; + 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) { - 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; + } 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; } /* @@ -681,13 +702,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 *)ckalloc(sizeof(EnsembleConfig)); + ensemblePtr = (EnsembleConfig *) ckalloc(sizeof(EnsembleConfig)); token = TclNRCreateCommandInNs(interp, name, (Tcl_Namespace *) nameNsPtr, TclEnsembleImplementationCmd, NsEnsembleImplementationCmdNR, ensemblePtr, DeleteEnsembleConfig); @@ -741,16 +763,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; @@ -769,6 +791,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) +{ + /* + * 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,14 +878,10 @@ Tcl_SetEnsembleSubcommandList( Tcl_Command token, 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) { @@ -810,7 +895,6 @@ Tcl_SetEnsembleSubcommandList( } } - ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData; oldList = ensemblePtr->subcmdList; ensemblePtr->subcmdList = subcmdList; if (subcmdList != NULL) { @@ -828,16 +912,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,15 +939,11 @@ Tcl_SetEnsembleParameterList( Tcl_Command token, 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) { @@ -886,7 +957,6 @@ Tcl_SetEnsembleParameterList( } } - ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData; oldList = ensemblePtr->parameterList; ensemblePtr->parameterList = paramList; if (paramList != NULL) { @@ -905,16 +975,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,14 +1002,10 @@ Tcl_SetEnsembleMappingDict( Tcl_Command token, 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) { @@ -974,7 +1031,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); @@ -987,7 +1044,6 @@ Tcl_SetEnsembleMappingDict( } } - ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData; oldDict = ensemblePtr->subcommandDict; ensemblePtr->subcommandDict = mapDict; if (mapDict != NULL) { @@ -1005,16 +1061,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,14 +1088,10 @@ Tcl_SetEnsembleUnknownHandler( Tcl_Command token, 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) { @@ -1062,7 +1105,6 @@ Tcl_SetEnsembleUnknownHandler( } } - ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData; oldList = ensemblePtr->unknownHandler; ensemblePtr->unknownHandler = unknownList; if (unknownList != NULL) { @@ -1107,20 +1149,13 @@ Tcl_SetEnsembleFlags( Tcl_Command token, 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... */ @@ -1143,16 +1178,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,19 +1213,11 @@ Tcl_GetEnsembleSubcommandList( Tcl_Command token, 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,19 +1247,11 @@ Tcl_GetEnsembleParameterList( Tcl_Command token, 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,19 +1281,11 @@ Tcl_GetEnsembleMappingDict( Tcl_Command token, 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,19 +1314,11 @@ Tcl_GetEnsembleUnknownHandler( Tcl_Command token, 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,19 +1347,11 @@ Tcl_GetEnsembleFlags( Tcl_Command token, 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,19 +1380,11 @@ Tcl_GetEnsembleNamespace( Tcl_Command token, 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; } @@ -1436,24 +1417,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", @@ -1465,7 +1445,7 @@ Tcl_FindEnsemble( } } - return (Tcl_Command) cmdPtr; + return token; } /* @@ -1516,6 +1496,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. * @@ -1528,8 +1513,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; @@ -1546,7 +1531,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] == ':') { @@ -1555,7 +1540,7 @@ TclMakeEnsemble( */ cmdName = name; - Tcl_DStringAppend(&buf, name, -1); + Tcl_DStringAppend(&buf, name, TCL_AUTO_LENGTH); ensembleFlags = TCL_ENSEMBLE_PREFIX; } else { /* @@ -1571,7 +1556,7 @@ TclMakeEnsemble( for (i = 0; i < nameCount; ++i) { TclDStringAppendLiteral(&buf, "::"); - Tcl_DStringAppend(&buf, nameParts[i], -1); + Tcl_DStringAppend(&buf, nameParts[i], TCL_AUTO_LENGTH); } } @@ -1618,7 +1603,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) { @@ -1636,7 +1621,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 { @@ -1698,12 +1684,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 @@ -1732,8 +1718,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 ...?"); @@ -1750,7 +1735,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; @@ -1773,8 +1759,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); @@ -1795,7 +1781,6 @@ NsEnsembleImplementationCmdNR( hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable, TclGetString(subObj)); if (hPtr != NULL) { - /* * Cache ensemble in the subcommand object for later. */ @@ -1865,7 +1850,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. @@ -1875,7 +1860,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: @@ -1932,7 +1917,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); } @@ -1976,12 +1961,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 ; isubcommandTable.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", @@ -2182,9 +2169,9 @@ TclSpellFix( if (search[0] == NULL) { store = (Tcl_Obj **) search[2]; } else { - Tcl_Obj **tmp = (Tcl_Obj **)ckalloc(3 * sizeof(Tcl_Obj *)); + Tcl_Obj **tmp = (Tcl_Obj **) ckalloc(3 * sizeof(Tcl_Obj *)); - store = (Tcl_Obj **)ckalloc(size * sizeof(Tcl_Obj *)); + store = (Tcl_Obj **) ckalloc(size * sizeof(Tcl_Obj *)); memcpy(store, iPtr->ensembleRewrite.sourceObjs, size * sizeof(Tcl_Obj *)); @@ -2214,7 +2201,7 @@ Tcl_Obj *const *TclEnsembleGetRewriteValues( 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; } @@ -2250,7 +2237,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; } @@ -2286,10 +2273,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; @@ -2322,7 +2311,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); } @@ -2370,16 +2360,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); @@ -2419,10 +2413,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; @@ -2437,7 +2432,7 @@ MakeCachedEnsembleCommand( * Replace any old internal representation with a new one. */ - ensembleCmd = (EnsembleCmdRep *)ckalloc(sizeof(EnsembleCmdRep)); + ensembleCmd = (EnsembleCmdRep *) ckalloc(sizeof(EnsembleCmdRep)); ECRSetInternalRep(objPtr, ensembleCmd); } @@ -2476,29 +2471,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); - } - ckfree((char *) ensemblePtr->subcommandArrayPtr); + while (hPtr != NULL) { + Tcl_Obj *prefixObj = (Tcl_Obj *) Tcl_GetHashValue(hPtr); + Tcl_DecrRefCount(prefixObj); + hPtr = Tcl_NextHashEntry(&search); + } + ckfree((char *) 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. */ @@ -2577,7 +2572,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. */ @@ -2592,100 +2587,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 @@ -2701,8 +2696,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 ; insPtr->numExportPatterns ; i++) { if (Tcl_StringMatch(nsCmdName, @@ -2750,8 +2745,8 @@ BuildEnsembleConfig( * the hash too, and vice versa, and run quicksort over the array. */ - ensemblePtr->subcommandArrayPtr = - (char **)ckalloc(sizeof(char *) * hash->numEntries); + ensemblePtr->subcommandArrayPtr = (char **) + ckalloc(sizeof(char *) * hash->numEntries); /* * Fill the array from both ends as this reduces the likelihood of @@ -2775,12 +2770,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) { @@ -2794,7 +2791,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, @@ -2808,8 +2806,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); } @@ -2871,7 +2869,8 @@ DupEnsembleCmdRep( Tcl_Obj *copyPtr) { EnsembleCmdRep *ensembleCmd; - EnsembleCmdRep *ensembleCopy = (EnsembleCmdRep *)ckalloc(sizeof(EnsembleCmdRep)); + EnsembleCmdRep *ensembleCopy = (EnsembleCmdRep *) + ckalloc(sizeof(EnsembleCmdRep)); ECRGetInternalRep(objPtr, ensembleCmd); ECRSetInternalRep(copyPtr, ensembleCopy); @@ -3139,7 +3138,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. @@ -3191,9 +3190,9 @@ TclCompileEnsemble( */ while (mapPtr->nuloc > eclIndex + 1) { - mapPtr->nuloc--; - ckfree(mapPtr->loc[mapPtr->nuloc].line); - mapPtr->loc[mapPtr->nuloc].line = NULL; + mapPtr->nuloc--; + ckfree(mapPtr->loc[mapPtr->nuloc].line); + mapPtr->loc[mapPtr->nuloc].line = NULL; } /* @@ -3407,7 +3406,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; } -- cgit v0.12 From fd8067d2421d7975e2c7acf19bc335c24b600e1a Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 16 Jun 2024 15:12:28 +0000 Subject: Some more improvements --- generic/tclEnsemble.c | 96 +++++++++++++++++++++++++++++++++++++++++++++------ generic/tclInt.h | 18 +++++----- 2 files changed, 94 insertions(+), 20 deletions(-) diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 711d59d..d3a84fc 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -166,7 +166,6 @@ TclNamespaceEnsembleCmd( int objc, Tcl_Obj *const objv[]) { - Tcl_Namespace *namespacePtr; Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp); Tcl_Command token; int index; @@ -184,8 +183,7 @@ 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; } @@ -248,7 +246,24 @@ TclNamespaceEnsembleCmd( } 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. + * + *---------------------------------------------------------------------- + */ static Tcl_Command InitEnsembleFromOptions( Tcl_Interp *interp, @@ -408,7 +423,23 @@ InitEnsembleFromOptions( } 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, @@ -464,7 +495,22 @@ ReadOneEnsembleOption( } 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, @@ -526,7 +572,22 @@ ReadAllEnsembleOptions( 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, @@ -2194,12 +2255,24 @@ TclSpellFix( TclNRAddCallback(interp, TclNRReleaseValues, fix, NULL, NULL, NULL); } -Tcl_Obj *const *TclEnsembleGetRewriteValues( - Tcl_Interp *interp /* Current interpreter. */ -) +/* + *---------------------------------------------------------------------- + * + * 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]; } @@ -3448,7 +3521,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 5a09f34..6221792 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1968,7 +1968,7 @@ typedef struct Interp { * compiled by the interpreter. Indexed by the * string representations of literals. Used to * avoid creating duplicate objects. */ - Tcl_Size compileEpoch; /* Holds the current "compilation epoch" for + Tcl_Size 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 @@ -1978,8 +1978,7 @@ typedef struct Interp { * 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 + ResolverScheme *resolverPtr;/* Linked list of name resolution schemes * added to this interpreter. Schemes are * added and removed by calling * Tcl_AddInterpResolvers and @@ -2018,7 +2017,8 @@ typedef struct Interp { /* First in list of active traces for interp, * or NULL if no active traces. */ - Tcl_Size tracesForbiddingInline; /* Count of traces (in the list headed by + Tcl_Size tracesForbiddingInline; + /* Count of traces (in the list headed by * tracePtr) that forbid inline bytecode * compilation. */ @@ -2048,7 +2048,7 @@ typedef struct Interp { * as flag values the same as the 'active' * field. */ - Tcl_Size cmdCount; /* Limit for how many commands to execute in + Tcl_Size cmdCount; /* Limit for how many commands to execute in * the interpreter. */ LimitHandler *cmdHandlers; /* Handlers to execute when the limit is @@ -2084,9 +2084,10 @@ typedef struct Interp { * *root* ensemble command? (Nested ensembles * don't rewrite this.) NULL if we're not * processing an ensemble. */ - Tcl_Size numRemovedObjs; /* How many arguments have been stripped off + 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; @@ -2146,8 +2147,7 @@ typedef struct Interp { * 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. - */ + * the bytecode compiler. */ /* * TIP #268. The currently active selection mode, i.e. the package require * preferences. -- cgit v0.12 From 3478e7593b2d6fa7f670944f8843ffbc4eac843f Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 16 Jun 2024 17:28:13 +0000 Subject: Better comments. --- generic/tclEnsemble.c | 53 +++++++++++++++++++++++++++++++++------------------ 1 file changed, 34 insertions(+), 19 deletions(-) diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index d3a84fc..faed738 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -125,6 +125,18 @@ typedef struct { * 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) @@ -167,7 +179,7 @@ TclNamespaceEnsembleCmd( Tcl_Obj *const objv[]) { Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp); - Tcl_Command token; + Tcl_Command token; /* The ensemble command. */ int index; if (nsPtr == NULL || nsPtr->flags & NS_DEAD) { @@ -262,6 +274,10 @@ TclNamespaceEnsembleCmd( * 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 @@ -277,7 +293,7 @@ InitEnsembleFromOptions( Tcl_Size len; int allocatedMapFlag = 0; int index; - Tcl_Command token; + Tcl_Command token; /* The created ensemble command. */ Namespace *foundNsPtr; const char *simpleName; /* @@ -443,7 +459,7 @@ InitEnsembleFromOptions( static int ReadOneEnsembleOption( Tcl_Interp *interp, - Tcl_Command token, /* The ensemble. */ + 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 */ @@ -514,7 +530,7 @@ ReadOneEnsembleOption( static int ReadAllEnsembleOptions( Tcl_Interp *interp, - Tcl_Command token) /* The ensemble. */ + Tcl_Command token) /* The ensemble to read from. */ { Tcl_Obj *resultObj, *tmpObj = NULL; /* silence gcc 4 warning */ int flags = 0; /* silence gcc 4 warning */ @@ -591,7 +607,7 @@ ReadAllEnsembleOptions( static int SetEnsembleConfigOptions( Tcl_Interp *interp, - Tcl_Command token, /* The ensemble. */ + Tcl_Command token, /* The ensemble to configure. */ int objc, /* The count of option-related arguments. */ Tcl_Obj *const objv[]) /* Option-related arguments. */ { @@ -904,7 +920,7 @@ GetEnsembleFromCommand( static inline void BumpEpochIfNecessary( Tcl_Interp *interp, - Tcl_Command token) + Tcl_Command token) /* The ensemble command to check. */ { /* * Special hack to make compiling of [info exists] work when the @@ -936,7 +952,7 @@ BumpEpochIfNecessary( int Tcl_SetEnsembleSubcommandList( Tcl_Interp *interp, - Tcl_Command token, + Tcl_Command token, /* The ensemble command to write to. */ Tcl_Obj *subcmdList) { EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token); @@ -997,7 +1013,7 @@ Tcl_SetEnsembleSubcommandList( int Tcl_SetEnsembleParameterList( Tcl_Interp *interp, - Tcl_Command token, + Tcl_Command token, /* The ensemble command to write to. */ Tcl_Obj *paramList) { EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token); @@ -1060,7 +1076,7 @@ Tcl_SetEnsembleParameterList( int Tcl_SetEnsembleMappingDict( Tcl_Interp *interp, - Tcl_Command token, + Tcl_Command token, /* The ensemble command to write to. */ Tcl_Obj *mapDict) { EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token); @@ -1146,7 +1162,7 @@ Tcl_SetEnsembleMappingDict( int Tcl_SetEnsembleUnknownHandler( Tcl_Interp *interp, - Tcl_Command token, + Tcl_Command token, /* The ensemble command to write to. */ Tcl_Obj *unknownList) { EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token); @@ -1207,7 +1223,7 @@ Tcl_SetEnsembleUnknownHandler( int Tcl_SetEnsembleFlags( Tcl_Interp *interp, - Tcl_Command token, + Tcl_Command token, /* The ensemble command to write to. */ int flags) { EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token); @@ -1271,7 +1287,7 @@ Tcl_SetEnsembleFlags( int Tcl_GetEnsembleSubcommandList( Tcl_Interp *interp, - Tcl_Command token, + Tcl_Command token, /* The ensemble command to read from. */ Tcl_Obj **subcmdListPtr) { EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token); @@ -1305,7 +1321,7 @@ Tcl_GetEnsembleSubcommandList( int Tcl_GetEnsembleParameterList( Tcl_Interp *interp, - Tcl_Command token, + Tcl_Command token, /* The ensemble command to read from. */ Tcl_Obj **paramListPtr) { EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token); @@ -1339,7 +1355,7 @@ Tcl_GetEnsembleParameterList( int Tcl_GetEnsembleMappingDict( Tcl_Interp *interp, - Tcl_Command token, + Tcl_Command token, /* The ensemble command to read from. */ Tcl_Obj **mapDictPtr) { EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token); @@ -1372,7 +1388,7 @@ Tcl_GetEnsembleMappingDict( int Tcl_GetEnsembleUnknownHandler( Tcl_Interp *interp, - Tcl_Command token, + Tcl_Command token, /* The ensemble command to read from. */ Tcl_Obj **unknownListPtr) { EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token); @@ -1405,7 +1421,7 @@ Tcl_GetEnsembleUnknownHandler( int Tcl_GetEnsembleFlags( Tcl_Interp *interp, - Tcl_Command token, + Tcl_Command token, /* The ensemble command to read from. */ int *flagsPtr) { EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token); @@ -1438,7 +1454,7 @@ Tcl_GetEnsembleFlags( int Tcl_GetEnsembleNamespace( Tcl_Interp *interp, - Tcl_Command token, + Tcl_Command token, /* The ensemble command to read from. */ Tcl_Namespace **namespacePtrPtr) { EnsembleConfig *ensemblePtr = GetEnsembleFromCommand(interp, token); @@ -1528,7 +1544,7 @@ Tcl_FindEnsemble( int Tcl_IsEnsemble( - Tcl_Command token) + Tcl_Command token) /* The command to check. */ { Command *cmdPtr = (Command *) token; @@ -2295,7 +2311,6 @@ TclEnsembleGetRewriteValues( * *---------------------------------------------------------------------- */ - Tcl_Obj *const * TclFetchEnsembleRoot( Tcl_Interp *interp, -- cgit v0.12