diff options
Diffstat (limited to 'generic/tclNamesp.c')
| -rw-r--r-- | generic/tclNamesp.c | 4549 |
1 files changed, 1453 insertions, 3096 deletions
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 2debd69..8f2f10e 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -5,33 +5,26 @@ * commands and global variables. The global :: namespace is the * traditional Tcl "global" scope. Other namespaces are created as * children of the global namespace. These other namespaces contain - * special-purpose commands and variables for packages. Also includes - * the TIP#112 ensemble machinery. + * special-purpose commands and variables for packages. * * Copyright (c) 1993-1997 Lucent Technologies. * Copyright (c) 1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 2002-2005 Donal K. Fellows. + * Copyright (c) 2006 Neil Madden. + * Contributions from Don Porter, NIST, 2007. (not subject to US copyright) * * Originally implemented by * Michael J. McLennan * Bell Labs Innovations for Lucent Technologies * mmclennan@lucent.com * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclNamesp.c,v 1.91 2006/01/11 17:34:53 dgp Exp $ + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" - -/* - * Initial size of stack allocated space for tail list - used when resetting - * shadowed command references in the functin: TclResetShadowedCmdRefs. - */ - -#define NUM_TRAIL_ELEMS 5 +#include "tclCompile.h" /* for TclLogCommandInfo visibility */ /* * Thread-local storage used to avoid having a global lock on data that is not @@ -60,14 +53,12 @@ static Tcl_ThreadDataKey dataKey; */ typedef struct ResolvedNsName { - Namespace *nsPtr; /* A cached namespace pointer. */ - long nsId; /* nsPtr's unique namespace id. Used to verify - * that nsPtr is still valid (e.g., it's - * possible that the namespace was deleted and - * a new one created at the same address). */ - Namespace *refNsPtr; /* Points to the namespace containing the - * reference (not the namespace that contains - * the referenced namespace). */ + Namespace *nsPtr; /* A cached pointer to the Namespace that the + * name resolved to. */ + Namespace *refNsPtr; /* Points to the namespace context in which + * the name was resolved. NULL if the name is + * fully qualified and thus the resolution + * does not depend on the context. */ int refCount; /* Reference count: 1 for each nsName object * that has a pointer to this ResolvedNsName * structure as its internal rep. This @@ -76,177 +67,77 @@ typedef struct ResolvedNsName { } ResolvedNsName; /* - * The client data for an ensemble command. This consists of the table of - * commands that are actually exported by the namespace, and an epoch counter - * that, combined with the exportLookupEpoch field of the namespace structure, - * defines whether the table contains valid data or will need to be recomputed - * next time the ensemble command is called. - */ - -typedef struct EnsembleConfig { - Namespace *nsPtr; /* The namspace backing this ensemble up. */ - Tcl_Command token; /* The token for the command that provides - * ensemble support for the namespace, or NULL - * if the command has been deleted (or never - * existed; the global namespace never has an - * ensemble command.) */ - int epoch; /* The epoch at which this ensemble's table of - * exported commands is valid. */ - char **subcommandArrayPtr; /* Array of ensemble subcommand names. At all - * consistent points, this will have the same - * number of entries as there are entries in - * the subcommandTable hash. */ - Tcl_HashTable subcommandTable; - /* Hash table of ensemble subcommand names, - * which are its keys so this also provides - * the storage management for those subcommand - * names. The contents of the entry values are - * object version the prefix lists to use when - * substituting for the command/subcommand to - * build the ensemble implementation command. - * Has to be stored here as well as in - * subcommandDict because that field is NULL - * when we are deriving the ensemble from the - * namespace exports list. FUTURE WORK: use - * object hash table here. */ - struct EnsembleConfig *next;/* The next ensemble in the linked list of - * ensembles associated with a namespace. If - * this field points to this ensemble, the - * structure has already been unlinked from - * all lists, and cannot be found by scanning - * the list from the namespace's ensemble - * field. */ - int flags; /* ORed combo of ENS_DEAD and - * TCL_ENSEMBLE_PREFIX. */ - - /* OBJECT FIELDS FOR ENSEMBLE CONFIGURATION */ - - Tcl_Obj *subcommandDict; /* Dictionary providing mapping from - * subcommands to their implementing command - * prefixes, or NULL if we are to build the - * map automatically from the namespace - * exports. */ - Tcl_Obj *subcmdList; /* List of commands that this ensemble - * actually provides, and whose implementation - * will be built using the subcommandDict (if - * present and defined) and by simple mapping - * to the namespace otherwise. If NULL, - * indicates that we are using the (dynamic) - * list of currently exported commands. */ - Tcl_Obj *unknownHandler; /* Script prefix used to handle the case when - * no match is found (according to the rule - * defined by flag bit TCL_ENSEMBLE_PREFIX) or - * NULL to use the default error-generating - * behaviour. The script execution gets all - * the arguments to the ensemble command - * (including objv[0]) and will have the - * results passed directly back to the caller - * (including the error code) unless the code - * is TCL_CONTINUE in which case the - * subcommand will be reparsed by the ensemble - * core, presumably because the ensemble - * itself has been updated. */ -} EnsembleConfig; - -#define ENS_DEAD 0x1 /* Flag value to say that the ensemble is dead - * and on its way out. */ - -/* - * The data cached in a subcommand's Tcl_Obj rep. This structure is not shared - * between Tcl_Objs referring to the same subcommand, even where one is a - * duplicate of another. - */ - -typedef struct EnsembleCmdRep { - Namespace *nsPtr; /* The namespace backing the ensemble which - * this is a subcommand of. */ - int epoch; /* Used to confirm when the data in this - * really structure matches up with the - * ensemble. */ - Tcl_Command token; /* Reference to the comamnd for which this - * structure is a cache of the resolution. */ - char *fullSubcmdName; /* The full (local) name of the subcommand, - * allocated with ckalloc(). */ - Tcl_Obj *realPrefixObj; /* Object containing the prefix words of the - * command that implements this ensemble - * subcommand. */ -} EnsembleCmdRep; - -/* * Declarations for functions local to this file: */ static void DeleteImportedCmd(ClientData clientData); static int DoImport(Tcl_Interp *interp, Namespace *nsPtr, Tcl_HashEntry *hPtr, - CONST char *cmdName, CONST char *pattern, + const char *cmdName, const char *pattern, Namespace *importNsPtr, int allowOverwrite); static void DupNsNameInternalRep(Tcl_Obj *objPtr,Tcl_Obj *copyPtr); static char * ErrorCodeRead(ClientData clientData,Tcl_Interp *interp, - CONST char *name1, CONST char *name2, int flags); + const char *name1, const char *name2, int flags); static char * ErrorInfoRead(ClientData clientData,Tcl_Interp *interp, - CONST char *name1, CONST char *name2, int flags); + const char *name1, const char *name2, int flags); static char * EstablishErrorCodeTraces(ClientData clientData, - Tcl_Interp *interp, CONST char *name1, - CONST char *name2, int flags); + Tcl_Interp *interp, const char *name1, + const char *name2, int flags); static char * EstablishErrorInfoTraces(ClientData clientData, - Tcl_Interp *interp, CONST char *name1, - CONST char *name2, int flags); + Tcl_Interp *interp, const char *name1, + const char *name2, int flags); static void FreeNsNameInternalRep(Tcl_Obj *objPtr); +static int GetNamespaceFromObj(Tcl_Interp *interp, + Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); static int InvokeImportedCmd(ClientData clientData, - Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[]); + Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); +static int InvokeImportedNRCmd(ClientData clientData, + Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static int NamespaceChildrenCmd(ClientData dummy, - Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[]); + Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static int NamespaceCodeCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); + int objc, Tcl_Obj *const objv[]); static int NamespaceCurrentCmd(ClientData dummy, - Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[]); + Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static int NamespaceDeleteCmd(ClientData dummy,Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); -static int NamespaceEnsembleCmd(ClientData dummy, - Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[]); + int objc, Tcl_Obj *const objv[]); static int NamespaceEvalCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); + int objc, Tcl_Obj *const objv[]); +static int NRNamespaceEvalCmd(ClientData dummy, + Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static int NamespaceExistsCmd(ClientData dummy,Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); + int objc, Tcl_Obj *const objv[]); static int NamespaceExportCmd(ClientData dummy,Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); + int objc, Tcl_Obj *const objv[]); static int NamespaceForgetCmd(ClientData dummy,Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); + int objc, Tcl_Obj *const objv[]); static void NamespaceFree(Namespace *nsPtr); static int NamespaceImportCmd(ClientData dummy,Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); + int objc, Tcl_Obj *const objv[]); static int NamespaceInscopeCmd(ClientData dummy, - Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[]); + Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); +static int NRNamespaceInscopeCmd(ClientData dummy, + Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static int NamespaceOriginCmd(ClientData dummy,Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); + int objc, Tcl_Obj *const objv[]); static int NamespaceParentCmd(ClientData dummy,Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); + int objc, Tcl_Obj *const objv[]); static int NamespacePathCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); + int objc, Tcl_Obj *const objv[]); static int NamespaceQualifiersCmd(ClientData dummy, - Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[]); + Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static int NamespaceTailCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); + int objc, Tcl_Obj *const objv[]); +static int NamespaceUpvarCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int NamespaceUnknownCmd(ClientData dummy, + Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static int NamespaceWhichCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); + int objc, Tcl_Obj *const objv[]); static int SetNsNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); -static void UpdateStringOfNsName(Tcl_Obj *objPtr); -static int NsEnsembleImplementationCmd(ClientData clientData, - Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[]); -static void BuildEnsembleConfig(EnsembleConfig *ensemblePtr); -static int NsEnsembleStringOrder(CONST VOID *strPtr1, - CONST VOID *strPtr2); -static void DeleteEnsembleConfig(ClientData clientData); -static void MakeCachedEnsembleCommand(Tcl_Obj *objPtr, - EnsembleConfig *ensemblePtr, - CONST char *subcmdName, Tcl_Obj *prefixObjPtr); -static void FreeEnsembleCmdRep(Tcl_Obj *objPtr); -static void DupEnsembleCmdRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); -static void StringOfEnsembleCmdRep(Tcl_Obj *objPtr); static void UnlinkNsPath(Namespace *nsPtr); -static void SetNsPath(Namespace *nsPtr, int pathLength, - Tcl_Namespace *pathAry[]); + +static Tcl_NRPostProc NsEval_Callback; /* * This structure defines a Tcl object type that contains a namespace @@ -255,27 +146,40 @@ static void SetNsPath(Namespace *nsPtr, int pathLength, * the object. */ -Tcl_ObjType tclNsNameType = { +static const Tcl_ObjType nsNameType = { "nsName", /* the type's name */ FreeNsNameInternalRep, /* freeIntRepProc */ DupNsNameInternalRep, /* dupIntRepProc */ - UpdateStringOfNsName, /* updateStringProc */ + NULL, /* updateStringProc */ SetNsNameFromAny /* setFromAnyProc */ }; /* - * This structure defines a Tcl object type that contains a reference to an - * ensemble subcommand (e.g. the "length" in [string length ab]) It is used to - * cache the mapping between the subcommand itself and the real command that - * implements it. + * Array of values describing how to implement each standard subcommand of the + * "namespace" command. */ -static Tcl_ObjType ensembleCmdType = { - "ensembleCommand", /* the type's name */ - FreeEnsembleCmdRep, /* freeIntRepProc */ - DupEnsembleCmdRep, /* dupIntRepProc */ - StringOfEnsembleCmdRep, /* updateStringProc */ - NULL /* setFromAnyProc */ +static const EnsembleImplMap defaultNamespaceMap[] = { + {"children", NamespaceChildrenCmd, TclCompileBasic0To2ArgCmd, NULL, NULL, 0}, + {"code", NamespaceCodeCmd, TclCompileNamespaceCodeCmd, NULL, NULL, 0}, + {"current", NamespaceCurrentCmd, TclCompileNamespaceCurrentCmd, NULL, NULL, 0}, + {"delete", NamespaceDeleteCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0}, + {"ensemble", TclNamespaceEnsembleCmd, NULL, NULL, NULL, 0}, + {"eval", NamespaceEvalCmd, NULL, NRNamespaceEvalCmd, NULL, 0}, + {"exists", NamespaceExistsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"export", NamespaceExportCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0}, + {"forget", NamespaceForgetCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0}, + {"import", NamespaceImportCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0}, + {"inscope", NamespaceInscopeCmd, NULL, NRNamespaceInscopeCmd, NULL, 0}, + {"origin", NamespaceOriginCmd, TclCompileNamespaceOriginCmd, NULL, NULL, 0}, + {"parent", NamespaceParentCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"path", NamespacePathCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"qualifiers", NamespaceQualifiersCmd, TclCompileNamespaceQualifiersCmd, NULL, NULL, 0}, + {"tail", NamespaceTailCmd, TclCompileNamespaceTailCmd, NULL, NULL, 0}, + {"unknown", NamespaceUnknownCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"upvar", NamespaceUpvarCmd, TclCompileNamespaceUpvarCmd, NULL, NULL, 0}, + {"which", NamespaceWhichCmd, TclCompileNamespaceWhichCmd, NULL, NULL, 0}, + {NULL, NULL, NULL, NULL, NULL, 0} }; /* @@ -324,15 +228,7 @@ Tcl_GetCurrentNamespace( register Tcl_Interp *interp)/* Interpreter whose current namespace is * being queried. */ { - register Interp *iPtr = (Interp *) interp; - register Namespace *nsPtr; - - if (iPtr->varFramePtr != NULL) { - nsPtr = iPtr->varFramePtr->nsPtr; - } else { - nsPtr = iPtr->globalNsPtr; - } - return (Tcl_Namespace *) nsPtr; + return TclGetCurrentNamespace(interp); } /* @@ -356,9 +252,7 @@ Tcl_GetGlobalNamespace( register Tcl_Interp *interp)/* Interpreter whose global namespace should * be returned. */ { - register Interp *iPtr = (Interp *) interp; - - return (Tcl_Namespace *) iPtr->globalNsPtr; + return TclGetGlobalNamespace(interp); } /* @@ -411,9 +305,19 @@ Tcl_PushCallFrame( register Namespace *nsPtr; if (namespacePtr == NULL) { - nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + nsPtr = (Namespace *) TclGetCurrentNamespace(interp); } else { nsPtr = (Namespace *) namespacePtr; + + /* + * TODO: Examine whether it would be better to guard based on NS_DYING + * or NS_KILLED. It appears that these are not tested because they can + * be set in a global interp that has been [namespace delete]d, but + * which never really completely goes away because of lingering global + * things like ::errorInfo and [::unknown] and hidden commands. + * Review of those designs might permit stricter checking here. + */ + if (nsPtr->flags & NS_DEAD) { Tcl_Panic("Trying to push call frame for dead namespace"); /*NOTREACHED*/ @@ -430,13 +334,16 @@ Tcl_PushCallFrame( if (iPtr->varFramePtr != NULL) { framePtr->level = (iPtr->varFramePtr->level + 1); } else { - framePtr->level = 1; + framePtr->level = 0; } framePtr->procPtr = NULL; /* no called procedure */ framePtr->varTablePtr = NULL; /* and no local variables */ framePtr->numCompiledLocals = 0; framePtr->compiledLocals = NULL; - + framePtr->clientData = NULL; + framePtr->localCachePtr = NULL; + framePtr->tailcallPtr = NULL; + /* * Push the new call frame onto the interpreter's stack of procedure call * frames making it the current frame. @@ -444,6 +351,7 @@ Tcl_PushCallFrame( iPtr->framePtr = framePtr; iPtr->varFramePtr = framePtr; + return TCL_OK; } @@ -480,16 +388,24 @@ Tcl_PopCallFrame( * the variable deletion don't see the partially-deleted frame. */ - iPtr->framePtr = framePtr->callerPtr; - iPtr->varFramePtr = framePtr->callerVarPtr; + if (framePtr->callerPtr) { + iPtr->framePtr = framePtr->callerPtr; + iPtr->varFramePtr = framePtr->callerVarPtr; + } else { + /* Tcl_PopCallFrame: trying to pop rootCallFrame! */ + } if (framePtr->varTablePtr != NULL) { TclDeleteVars(iPtr, framePtr->varTablePtr); - ckfree((char *) framePtr->varTablePtr); + ckfree(framePtr->varTablePtr); framePtr->varTablePtr = NULL; } if (framePtr->numCompiledLocals > 0) { TclDeleteCompiledLocalVars(iPtr, framePtr); + if (--framePtr->localCachePtr->refCount == 0) { + TclFreeLocalCache(interp, framePtr->localCachePtr); + } + framePtr->localCachePtr = NULL; } /* @@ -500,10 +416,15 @@ Tcl_PopCallFrame( nsPtr = framePtr->nsPtr; nsPtr->activationCount--; - if ((nsPtr->flags & NS_DYING) && (nsPtr->activationCount == 0)) { + if ((nsPtr->flags & NS_DYING) + && (nsPtr->activationCount - (nsPtr == iPtr->globalNsPtr) == 0)) { Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr); } framePtr->nsPtr = NULL; + + if (framePtr->tailcallPtr) { + TclSetTailcall(interp, framePtr->tailcallPtr); + } } /* @@ -530,7 +451,7 @@ TclPushStackFrame( Tcl_Interp *interp, /* Interpreter in which the new call frame is * to be pushed. */ Tcl_CallFrame **framePtrPtr,/* Place to store a pointer to the stack - * allocated call frame.*/ + * allocated call frame. */ Tcl_Namespace *namespacePtr,/* Points to the namespace in which the frame * will execute. If NULL, the interpreter's * current namespace will be used. */ @@ -544,7 +465,7 @@ TclPushStackFrame( * treated as references to namespace * variables. */ { - *framePtrPtr = (Tcl_CallFrame *) TclStackAlloc(interp, sizeof(CallFrame)); + *framePtrPtr = TclStackAlloc(interp, sizeof(CallFrame)); return Tcl_PushCallFrame(interp, *framePtrPtr, namespacePtr, isProcCallFrame); } @@ -553,8 +474,10 @@ void TclPopStackFrame( Tcl_Interp *interp) /* Interpreter with call frame to pop. */ { + CallFrame *freePtr = ((Interp *) interp)->framePtr; + Tcl_PopCallFrame(interp); - TclStackFree(interp); + TclStackFree(interp, freePtr); } /* @@ -578,14 +501,14 @@ static char * EstablishErrorCodeTraces( ClientData clientData, Tcl_Interp *interp, - CONST char *name1, - CONST char *name2, + const char *name1, + const char *name2, int flags) { - Tcl_TraceVar(interp, "errorCode", TCL_GLOBAL_ONLY | TCL_TRACE_READS, - ErrorCodeRead, (ClientData) NULL); - Tcl_TraceVar(interp, "errorCode", TCL_GLOBAL_ONLY | TCL_TRACE_UNSETS, - EstablishErrorCodeTraces, (ClientData) NULL); + Tcl_TraceVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS, + ErrorCodeRead, NULL); + Tcl_TraceVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_UNSETS, + EstablishErrorCodeTraces, NULL); return NULL; } @@ -610,17 +533,24 @@ static char * ErrorCodeRead( ClientData clientData, Tcl_Interp *interp, - CONST char *name1, - CONST char *name2, + const char *name1, + const char *name2, int flags) { - Interp *iPtr = (Interp *)interp; + Interp *iPtr = (Interp *) interp; - if (flags & TCL_INTERP_DESTROYED || iPtr->errorCode == NULL) { + if (Tcl_InterpDeleted(interp) || !(iPtr->flags & ERR_LEGACY_COPY)) { + return NULL; + } + if (iPtr->errorCode) { + Tcl_ObjSetVar2(interp, iPtr->ecVar, NULL, + iPtr->errorCode, TCL_GLOBAL_ONLY); return NULL; } - Tcl_ObjSetVar2(interp, iPtr->ecVar, NULL, iPtr->errorCode, - TCL_GLOBAL_ONLY); + if (NULL == Tcl_ObjGetVar2(interp, iPtr->ecVar, NULL, TCL_GLOBAL_ONLY)) { + Tcl_ObjSetVar2(interp, iPtr->ecVar, NULL, + Tcl_NewObj(), TCL_GLOBAL_ONLY); + } return NULL; } @@ -645,14 +575,14 @@ static char * EstablishErrorInfoTraces( ClientData clientData, Tcl_Interp *interp, - CONST char *name1, - CONST char *name2, + const char *name1, + const char *name2, int flags) { - Tcl_TraceVar(interp, "errorInfo", TCL_GLOBAL_ONLY | TCL_TRACE_READS, - ErrorInfoRead, (ClientData) NULL); - Tcl_TraceVar(interp, "errorInfo", TCL_GLOBAL_ONLY | TCL_TRACE_UNSETS, - EstablishErrorInfoTraces, (ClientData) NULL); + Tcl_TraceVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS, + ErrorInfoRead, NULL); + Tcl_TraceVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_UNSETS, + EstablishErrorInfoTraces, NULL); return NULL; } @@ -677,17 +607,24 @@ static char * ErrorInfoRead( ClientData clientData, Tcl_Interp *interp, - CONST char *name1, - CONST char *name2, + const char *name1, + const char *name2, int flags) { - Interp *iPtr = (Interp *)interp; + Interp *iPtr = (Interp *) interp; - if (flags & TCL_INTERP_DESTROYED || iPtr->errorInfo == NULL) { + if (Tcl_InterpDeleted(interp) || !(iPtr->flags & ERR_LEGACY_COPY)) { return NULL; } - Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, iPtr->errorInfo, - TCL_GLOBAL_ONLY); + if (iPtr->errorInfo) { + Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, + iPtr->errorInfo, TCL_GLOBAL_ONLY); + return NULL; + } + if (NULL == Tcl_ObjGetVar2(interp, iPtr->eiVar, NULL, TCL_GLOBAL_ONLY)) { + Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, + Tcl_NewObj(), TCL_GLOBAL_ONLY); + } return NULL; } @@ -717,7 +654,7 @@ Tcl_CreateNamespace( Tcl_Interp *interp, /* Interpreter in which a new namespace is * being created. Also used for error * reporting. */ - CONST char *name, /* Name for the new namespace. May be a + const char *name, /* Name for the new namespace. May be a * qualified name with names of ancestor * namespaces separated by "::"s. */ ClientData clientData, /* One-word value to store with namespace. */ @@ -730,11 +667,16 @@ Tcl_CreateNamespace( register Namespace *nsPtr, *ancestorPtr; Namespace *parentPtr, *dummy1Ptr, *dummy2Ptr; Namespace *globalNsPtr = iPtr->globalNsPtr; - CONST char *simpleName; + const char *simpleName; Tcl_HashEntry *entryPtr; Tcl_DString buffer1, buffer2; - int newEntry; + Tcl_DString *namePtr, *buffPtr; + int newEntry, nameLen; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + const char *nameStr; + Tcl_DString tmpBuffer; + + Tcl_DStringInit(&tmpBuffer); /* * If there is no active namespace, the interpreter is being initialized. @@ -748,40 +690,78 @@ Tcl_CreateNamespace( parentPtr = NULL; simpleName = ""; - } else if (*name == '\0') { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "can't create namespace \"\": ", - "only global namespace can have empty name", NULL); + goto doCreate; + } + + /* + * Ensure that there are no trailing colons as that causes chaos when a + * deleteProc is specified. [Bug d614d63989] + */ + + if (deleteProc != NULL) { + nameStr = name + strlen(name) - 2; + if (nameStr >= name && nameStr[1] == ':' && nameStr[0] == ':') { + Tcl_DStringAppend(&tmpBuffer, name, -1); + while ((nameLen = Tcl_DStringLength(&tmpBuffer)) > 0 + && Tcl_DStringValue(&tmpBuffer)[nameLen-1] == ':') { + Tcl_DStringSetLength(&tmpBuffer, nameLen-1); + } + name = Tcl_DStringValue(&tmpBuffer); + } + } + + /* + * If we've ended up with an empty string now, we're attempting to create + * the global namespace despite the global namespace existing. That's + * naughty! + */ + + if (*name == '\0') { + Tcl_SetObjResult(interp, Tcl_NewStringObj("can't create namespace" + " \"\": only global namespace can have empty name", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE", + "CREATEGLOBAL", NULL); + Tcl_DStringFree(&tmpBuffer); return NULL; - } else { - /* - * Find the parent for the new namespace. - */ + } - TclGetNamespaceForQualName(interp, name, NULL, - /*flags*/ (TCL_CREATE_NS_IF_UNKNOWN | TCL_LEAVE_ERR_MSG), - &parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName); + /* + * Find the parent for the new namespace. + */ - /* - * If the unqualified name at the end is empty, there were trailing - * "::"s after the namespace's name which we ignore. The new namespace - * was already (recursively) created and is pointed to by parentPtr. - */ + TclGetNamespaceForQualName(interp, name, NULL, TCL_CREATE_NS_IF_UNKNOWN, + &parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName); - if (*simpleName == '\0') { - return (Tcl_Namespace *) parentPtr; - } + /* + * If the unqualified name at the end is empty, there were trailing "::"s + * after the namespace's name which we ignore. The new namespace was + * already (recursively) created and is pointed to by parentPtr. + */ - /* - * Check for a bad namespace name and make sure that the name does not - * already exist in the parent namespace. - */ + if (*simpleName == '\0') { + Tcl_DStringFree(&tmpBuffer); + return (Tcl_Namespace *) parentPtr; + } - if (Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL) { - Tcl_AppendResult(interp, "can't create namespace \"", name, - "\": already exists", NULL); - return NULL; - } + /* + * Check for a bad namespace name and make sure that the name does not + * already exist in the parent namespace. + */ + + if ( +#ifndef BREAK_NAMESPACE_COMPAT + Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL +#else + parentPtr->childTablePtr != NULL && + Tcl_FindHashEntry(parentPtr->childTablePtr, simpleName) != NULL +#endif + ) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create namespace \"%s\": already exists", name)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE", + "CREATEEXISTING", NULL); + Tcl_DStringFree(&tmpBuffer); + return NULL; } /* @@ -789,21 +769,27 @@ Tcl_CreateNamespace( * of namespaces created. */ - nsPtr = (Namespace *) ckalloc(sizeof(Namespace)); - nsPtr->name = (char *) ckalloc((unsigned) (strlen(simpleName)+1)); - strcpy(nsPtr->name, simpleName); - nsPtr->fullName = NULL; /* set below */ + doCreate: + nsPtr = ckalloc(sizeof(Namespace)); + nameLen = strlen(simpleName) + 1; + nsPtr->name = ckalloc(nameLen); + memcpy(nsPtr->name, simpleName, nameLen); + nsPtr->fullName = NULL; /* Set below. */ nsPtr->clientData = clientData; nsPtr->deleteProc = deleteProc; nsPtr->parentPtr = parentPtr; +#ifndef BREAK_NAMESPACE_COMPAT Tcl_InitHashTable(&nsPtr->childTable, TCL_STRING_KEYS); +#else + nsPtr->childTablePtr = NULL; +#endif nsPtr->nsId = ++(tsdPtr->numNsCreated); nsPtr->interp = interp; nsPtr->flags = 0; nsPtr->activationCount = 0; nsPtr->refCount = 0; Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS); - Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS); + TclInitVarHashTable(&nsPtr->varTable, nsPtr); nsPtr->exportArrayPtr = NULL; nsPtr->numExportPatterns = 0; nsPtr->maxExportPatterns = 0; @@ -814,14 +800,17 @@ Tcl_CreateNamespace( nsPtr->compiledVarResProc = NULL; nsPtr->exportLookupEpoch = 0; nsPtr->ensembles = NULL; + nsPtr->unknownHandlerPtr = NULL; nsPtr->commandPathLength = 0; nsPtr->commandPathArray = NULL; nsPtr->commandPathSourceList = NULL; + nsPtr->earlyDeleteProc = NULL; if (parentPtr != NULL) { - entryPtr = Tcl_CreateHashEntry(&parentPtr->childTable, simpleName, - &newEntry); - Tcl_SetHashValue(entryPtr, (ClientData) nsPtr); + entryPtr = Tcl_CreateHashEntry( + TclGetNamespaceChildTable((Tcl_Namespace *) parentPtr), + simpleName, &newEntry); + Tcl_SetHashValue(entryPtr, nsPtr); } else { /* * In the global namespace create traces to maintain the ::errorInfo @@ -839,25 +828,54 @@ Tcl_CreateNamespace( Tcl_DStringInit(&buffer1); Tcl_DStringInit(&buffer2); - for (ancestorPtr = nsPtr; ancestorPtr != NULL; + namePtr = &buffer1; + buffPtr = &buffer2; + for (ancestorPtr = nsPtr; ancestorPtr != NULL; ancestorPtr = ancestorPtr->parentPtr) { if (ancestorPtr != globalNsPtr) { - Tcl_DStringAppend(&buffer1, "::", 2); - Tcl_DStringAppend(&buffer1, ancestorPtr->name, -1); - } - Tcl_DStringAppend(&buffer1, Tcl_DStringValue(&buffer2), -1); + register Tcl_DString *tempPtr = namePtr; + + TclDStringAppendLiteral(buffPtr, "::"); + Tcl_DStringAppend(buffPtr, ancestorPtr->name, -1); + TclDStringAppendDString(buffPtr, namePtr); + + /* + * Clear the unwanted buffer or we end up appending to previous + * results, making the namespace fullNames of nested namespaces + * very wrong (and strange). + */ + + TclDStringClear(namePtr); - Tcl_DStringSetLength(&buffer2, 0); - Tcl_DStringAppend(&buffer2, Tcl_DStringValue(&buffer1), -1); - Tcl_DStringSetLength(&buffer1, 0); + /* + * Now swap the buffer pointers so that we build in the other + * buffer. This is faster than repeated copying back and forth + * between buffers. + */ + + namePtr = buffPtr; + buffPtr = tempPtr; + } } - name = Tcl_DStringValue(&buffer2); - nsPtr->fullName = (char *) ckalloc((unsigned) (strlen(name)+1)); - strcpy(nsPtr->fullName, name); + name = Tcl_DStringValue(namePtr); + nameLen = Tcl_DStringLength(namePtr); + nsPtr->fullName = ckalloc(nameLen + 1); + memcpy(nsPtr->fullName, name, (unsigned) nameLen + 1); Tcl_DStringFree(&buffer1); Tcl_DStringFree(&buffer2); + Tcl_DStringFree(&tmpBuffer); + + /* + * If compilation of commands originating from the parent NS is + * suppressed, suppress it for commands originating in this one too. + */ + + if (nsPtr->parentPtr != NULL && + nsPtr->parentPtr->flags & NS_SUPPRESS_COMPILATION) { + nsPtr->flags |= NS_SUPPRESS_COMPILATION; + } /* * Return a pointer to the new namespace. @@ -887,13 +905,57 @@ Tcl_CreateNamespace( void Tcl_DeleteNamespace( - Tcl_Namespace *namespacePtr)/* Points to the namespace to delete */ + Tcl_Namespace *namespacePtr)/* Points to the namespace to delete. */ { register Namespace *nsPtr = (Namespace *) namespacePtr; Interp *iPtr = (Interp *) nsPtr->interp; - Namespace *globalNsPtr = - (Namespace *) Tcl_GetGlobalNamespace((Tcl_Interp *) iPtr); + Namespace *globalNsPtr = (Namespace *) + TclGetGlobalNamespace((Tcl_Interp *) iPtr); Tcl_HashEntry *entryPtr; + Tcl_HashSearch search; + Command *cmdPtr; + + /* + * Give anyone interested - notably TclOO - a chance to use this namespace + * normally despite the fact that the namespace is going to go. Allows the + * calling of destructors. Will only be called once (unless re-established + * by the called function). [Bug 2950259] + * + * Note that setting this field requires access to the internal definition + * of namespaces, so it should only be accessed by code that knows about + * being careful with reentrancy. + */ + + if (nsPtr->earlyDeleteProc != NULL) { + Tcl_NamespaceDeleteProc *earlyDeleteProc = nsPtr->earlyDeleteProc; + + nsPtr->earlyDeleteProc = NULL; + nsPtr->activationCount++; + earlyDeleteProc(nsPtr->clientData); + nsPtr->activationCount--; + } + + /* + * Delete all coroutine commands now: break the circular ref cycle between + * the namespace and the coroutine command [Bug 2724403]. This code is + * essentially duplicated in TclTeardownNamespace() for all other + * commands. Don't optimize to Tcl_NextHashEntry() because of traces. + * + * NOTE: we could avoid traversing the ns's command list by keeping a + * separate list of coros. + */ + + for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); + entryPtr != NULL;) { + cmdPtr = Tcl_GetHashValue(entryPtr); + if (cmdPtr->nreProc == TclNRInterpCoroutine) { + Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, + (Tcl_Command) cmdPtr); + entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); + } else { + entryPtr = Tcl_NextHashEntry(&search); + } + } /* * If the namespace has associated ensemble commands, delete them first. @@ -915,6 +977,16 @@ Tcl_DeleteNamespace( } /* + * If the namespace has a registered unknown handler (TIP 181), then free + * it here. + */ + + if (nsPtr->unknownHandlerPtr != NULL) { + Tcl_DecrRefCount(nsPtr->unknownHandlerPtr); + nsPtr->unknownHandlerPtr = NULL; + } + + /* * If the namespace is on the call frame stack, it is marked as "dying" * (NS_DYING is OR'd into its flags): the namespace can't be looked up by * name but its commands and variables are still usable by those active @@ -931,11 +1003,12 @@ Tcl_DeleteNamespace( * refCount reaches 0. */ - if (nsPtr->activationCount > 0) { + if (nsPtr->activationCount - (nsPtr == globalNsPtr) > 0) { nsPtr->flags |= NS_DYING; if (nsPtr->parentPtr != NULL) { - entryPtr = Tcl_FindHashEntry(&nsPtr->parentPtr->childTable, - nsPtr->name); + entryPtr = Tcl_FindHashEntry( + TclGetNamespaceChildTable((Tcl_Namespace *) + nsPtr->parentPtr), nsPtr->name); if (entryPtr != NULL) { Tcl_DeleteHashEntry(entryPtr); } @@ -964,7 +1037,14 @@ Tcl_DeleteNamespace( TclDeleteNamespaceVars(nsPtr); +#ifndef BREAK_NAMESPACE_COMPAT Tcl_DeleteHashTable(&nsPtr->childTable); +#else + if (nsPtr->childTablePtr != NULL) { + Tcl_DeleteHashTable(nsPtr->childTablePtr); + ckfree(nsPtr->childTablePtr); + } +#endif Tcl_DeleteHashTable(&nsPtr->cmdTable); /* @@ -984,6 +1064,13 @@ Tcl_DeleteNamespace( EstablishErrorInfoTraces(NULL, nsPtr->interp, NULL, NULL, 0); EstablishErrorCodeTraces(NULL, nsPtr->interp, NULL, NULL, 0); + + /* + * We didn't really kill it, so remove the KILLED marks, so it can + * get killed later, avoiding mem leaks. + */ + + nsPtr->flags &= ~(NS_DYING|NS_KILLED); } } } @@ -1029,7 +1116,7 @@ TclTeardownNamespace( */ TclDeleteNamespaceVars(nsPtr); - Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS); + TclInitVarHashTable(&nsPtr->varTable, nsPtr); /* * Delete all commands in this namespace. Be careful when traversing the @@ -1042,7 +1129,7 @@ TclTeardownNamespace( for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); entryPtr != NULL; entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search)) { - cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr); + cmd = Tcl_GetHashValue(entryPtr); Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, cmd); } Tcl_DeleteHashTable(&nsPtr->cmdTable); @@ -1053,8 +1140,9 @@ TclTeardownNamespace( */ if (nsPtr->parentPtr != NULL) { - entryPtr = Tcl_FindHashEntry(&nsPtr->parentPtr->childTable, - nsPtr->name); + entryPtr = Tcl_FindHashEntry( + TclGetNamespaceChildTable((Tcl_Namespace *) + nsPtr->parentPtr), nsPtr->name); if (entryPtr != NULL) { Tcl_DeleteHashEntry(entryPtr); } @@ -1071,29 +1159,44 @@ TclTeardownNamespace( } if (nsPtr->commandPathSourceList != NULL) { NamespacePathEntry *nsPathPtr = nsPtr->commandPathSourceList; + do { + if (nsPathPtr->nsPtr != NULL && nsPathPtr->creatorNsPtr != NULL) { + nsPathPtr->creatorNsPtr->cmdRefEpoch++; + } nsPathPtr->nsPtr = NULL; nsPathPtr = nsPathPtr->nextPtr; } while (nsPathPtr != NULL); + nsPtr->commandPathSourceList = NULL; } /* * Delete all the child namespaces. * * BE CAREFUL: When each child is deleted, it will divorce itself from its - * parent. You can't traverse a hash table properly if its elements are - * being deleted. We use only the Tcl_FirstHashEntry function to be - * safe. + * parent. You can't traverse a hash table properly if its elements are + * being deleted. We use only the Tcl_FirstHashEntry function to be safe. * * Don't optimize to Tcl_NextHashEntry() because of traces. */ +#ifndef BREAK_NAMESPACE_COMPAT for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); entryPtr != NULL; entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search)) { - childNsPtr = (Tcl_Namespace *) Tcl_GetHashValue(entryPtr); + childNsPtr = Tcl_GetHashValue(entryPtr); Tcl_DeleteNamespace(childNsPtr); } +#else + if (nsPtr->childTablePtr != NULL) { + for (entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search); + entryPtr != NULL; + entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr,&search)) { + childNsPtr = Tcl_GetHashValue(entryPtr); + Tcl_DeleteNamespace(childNsPtr); + } + } +#endif /* * Free the namespace's export pattern array. @@ -1103,7 +1206,7 @@ TclTeardownNamespace( for (i = 0; i < nsPtr->numExportPatterns; i++) { ckfree(nsPtr->exportArrayPtr[i]); } - ckfree((char *) nsPtr->exportArrayPtr); + ckfree(nsPtr->exportArrayPtr); nsPtr->exportArrayPtr = NULL; nsPtr->numExportPatterns = 0; nsPtr->maxExportPatterns = 0; @@ -1114,7 +1217,7 @@ TclTeardownNamespace( */ if (nsPtr->deleteProc != NULL) { - (*nsPtr->deleteProc)(nsPtr->clientData); + nsPtr->deleteProc(nsPtr->clientData); } nsPtr->deleteProc = NULL; nsPtr->clientData = NULL; @@ -1157,8 +1260,34 @@ NamespaceFree( ckfree(nsPtr->name); ckfree(nsPtr->fullName); + ckfree(nsPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TclNsDecrRefCount -- + * + * Drops a reference to a namespace and frees it if the namespace has + * been deleted and the last reference has just been dropped. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - ckfree((char *) nsPtr); +void +TclNsDecrRefCount( + Namespace *nsPtr) +{ + nsPtr->refCount--; + if ((nsPtr->refCount == 0) && (nsPtr->flags & NS_DEAD)) { + NamespaceFree(nsPtr); + } } /* @@ -1189,7 +1318,7 @@ Tcl_Export( Tcl_Namespace *namespacePtr,/* Points to the namespace from which commands * are to be exported. NULL for the current * namespace. */ - CONST char *pattern, /* String pattern indicating which commands to + const char *pattern, /* String pattern indicating which commands to * export. This pattern may not include any * namespace qualifiers; only commands in the * specified namespace may be exported. */ @@ -1198,8 +1327,8 @@ Tcl_Export( { #define INIT_EXPORT_PATTERNS 5 Namespace *nsPtr, *exportNsPtr, *dummyPtr; - Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); - CONST char *simplePattern; + Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp); + const char *simplePattern; char *patternCpy; int neededElems, len, i; @@ -1223,7 +1352,7 @@ Tcl_Export( for (i = 0; i < nsPtr->numExportPatterns; i++) { ckfree(nsPtr->exportArrayPtr[i]); } - ckfree((char *) nsPtr->exportArrayPtr); + ckfree(nsPtr->exportArrayPtr); nsPtr->exportArrayPtr = NULL; TclInvalidateNsCmdLookup(nsPtr); nsPtr->numExportPatterns = 0; @@ -1235,13 +1364,13 @@ Tcl_Export( * Check that the pattern doesn't have namespace qualifiers. */ - TclGetNamespaceForQualName(interp, pattern, nsPtr, - /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY), + TclGetNamespaceForQualName(interp, pattern, nsPtr, TCL_NAMESPACE_ONLY, &exportNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) { - Tcl_AppendResult(interp, "invalid export pattern \"", pattern, - "\": pattern can't specify a namespace", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("invalid export pattern" + " \"%s\": pattern can't specify a namespace", pattern)); + Tcl_SetErrorCode(interp, "TCL", "EXPORT", "INVALID", NULL); return TCL_ERROR; } @@ -1253,8 +1382,9 @@ Tcl_Export( for (i = 0; i < nsPtr->numExportPatterns; i++) { if (strcmp(pattern, nsPtr->exportArrayPtr[i]) == 0) { /* - * The pattern already exists in the list + * The pattern already exists in the list. */ + return TCL_OK; } } @@ -1266,21 +1396,11 @@ Tcl_Export( */ neededElems = nsPtr->numExportPatterns + 1; - if (nsPtr->exportArrayPtr == NULL) { - nsPtr->exportArrayPtr = (char **) - ckalloc((unsigned) (INIT_EXPORT_PATTERNS * sizeof(char *))); - nsPtr->numExportPatterns = 0; - nsPtr->maxExportPatterns = INIT_EXPORT_PATTERNS; - } else if (neededElems > nsPtr->maxExportPatterns) { - int numNewElems = 2 * nsPtr->maxExportPatterns; - size_t currBytes = nsPtr->numExportPatterns * sizeof(char *); - size_t newBytes = numNewElems * sizeof(char *); - char **newPtr = (char **) ckalloc((unsigned) newBytes); - - memcpy((void *) newPtr, (void *) nsPtr->exportArrayPtr, currBytes); - ckfree((char *) nsPtr->exportArrayPtr); - nsPtr->exportArrayPtr = (char **) newPtr; - nsPtr->maxExportPatterns = numNewElems; + if (neededElems > nsPtr->maxExportPatterns) { + nsPtr->maxExportPatterns = nsPtr->maxExportPatterns ? + 2 * nsPtr->maxExportPatterns : INIT_EXPORT_PATTERNS; + nsPtr->exportArrayPtr = ckrealloc(nsPtr->exportArrayPtr, + sizeof(char *) * nsPtr->maxExportPatterns); } /* @@ -1288,8 +1408,8 @@ Tcl_Export( */ len = strlen(pattern); - patternCpy = (char *) ckalloc((unsigned) (len + 1)); - strcpy(patternCpy, pattern); + patternCpy = ckalloc(len + 1); + memcpy(patternCpy, pattern, (unsigned) len + 1); nsPtr->exportArrayPtr[nsPtr->numExportPatterns] = patternCpy; nsPtr->numExportPatterns++; @@ -1344,7 +1464,7 @@ Tcl_AppendExportList( */ if (namespacePtr == NULL) { - nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + nsPtr = (Namespace *) TclGetCurrentNamespace(interp); } else { nsPtr = (Namespace *) namespacePtr; } @@ -1395,7 +1515,7 @@ Tcl_Import( Tcl_Namespace *namespacePtr,/* Points to the namespace into which the * commands are to be imported. NULL for the * current namespace. */ - CONST char *pattern, /* String pattern indicating which commands to + const char *pattern, /* String pattern indicating which commands to * import. This pattern should be qualified by * the name of the namespace from which to * import the command(s). */ @@ -1405,7 +1525,7 @@ Tcl_Import( * conflicts with an existing one. */ { Namespace *nsPtr, *importNsPtr, *dummyPtr; - CONST char *simplePattern; + const char *simplePattern; register Tcl_HashEntry *hPtr; Tcl_HashSearch search; @@ -1414,7 +1534,7 @@ Tcl_Import( */ if (namespacePtr == NULL) { - nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + nsPtr = (Namespace *) TclGetCurrentNamespace(interp); } else { nsPtr = (Namespace *) namespacePtr; } @@ -1433,7 +1553,7 @@ Tcl_Import( Tcl_Obj *objv[2]; int result; - objv[0] = Tcl_NewStringObj("auto_import", -1); + TclNewLiteralStringObj(objv[0], "auto_import"); objv[1] = Tcl_NewStringObj(pattern, -1); Tcl_IncrRefCount(objv[0]); @@ -1454,27 +1574,30 @@ Tcl_Import( */ if (strlen(pattern) == 0) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("empty import pattern", -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj("empty import pattern",-1)); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "EMPTY", NULL); return TCL_ERROR; } - TclGetNamespaceForQualName(interp, pattern, nsPtr, - /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY), + TclGetNamespaceForQualName(interp, pattern, nsPtr, TCL_NAMESPACE_ONLY, &importNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if (importNsPtr == NULL) { - Tcl_AppendResult(interp, "unknown namespace in import pattern \"", - pattern, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown namespace in import pattern \"%s\"", pattern)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, NULL); return TCL_ERROR; } if (importNsPtr == nsPtr) { if (pattern == simplePattern) { - Tcl_AppendResult(interp, - "no namespace specified in import pattern \"", pattern, - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "no namespace specified in import pattern \"%s\"", + pattern)); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "ORIGIN", NULL); } else { - Tcl_AppendResult(interp, "import pattern \"", pattern, - "\" tries to import from namespace \"", - importNsPtr->name, "\" into itself", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "import pattern \"%s\" tries to import from namespace" + " \"%s\" into itself", pattern, importNsPtr->name)); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "SELF", NULL); } return TCL_ERROR; } @@ -1497,6 +1620,7 @@ Tcl_Import( for (hPtr = Tcl_FirstHashEntry(&importNsPtr->cmdTable, &search); (hPtr != NULL); hPtr = Tcl_NextHashEntry(&search)) { char *cmdName = Tcl_GetHashKey(&importNsPtr->cmdTable, hPtr); + if (Tcl_StringMatch(cmdName, simplePattern) && DoImport(interp, nsPtr, hPtr, cmdName, pattern, importNsPtr, allowOverwrite) == TCL_ERROR) { @@ -1530,8 +1654,8 @@ DoImport( Tcl_Interp *interp, Namespace *nsPtr, Tcl_HashEntry *hPtr, - CONST char *cmdName, - CONST char *pattern, + const char *cmdName, + const char *pattern, Namespace *importNsPtr, int allowOverwrite) { @@ -1544,7 +1668,8 @@ DoImport( */ while (!exported && (i < importNsPtr->numExportPatterns)) { - exported |= Tcl_StringMatch(cmdName, importNsPtr->exportArrayPtr[i++]); + exported |= Tcl_StringMatch(cmdName, + importNsPtr->exportArrayPtr[i++]); } if (!exported) { return TCL_OK; @@ -1572,7 +1697,7 @@ DoImport( Tcl_DStringInit(&ds); Tcl_DStringAppend(&ds, nsPtr->fullName, -1); if (nsPtr != ((Interp *) interp)->globalNsPtr) { - Tcl_DStringAppend(&ds, "::", 2); + TclDStringAppendLiteral(&ds, "::"); } Tcl_DStringAppend(&ds, cmdName, -1); @@ -1581,29 +1706,30 @@ DoImport( * namespace would create a cycle of imported command references. */ - cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + cmdPtr = Tcl_GetHashValue(hPtr); if (found != NULL && cmdPtr->deleteProc == DeleteImportedCmd) { - Command *overwrite = (Command *) Tcl_GetHashValue(found); - Command *link = cmdPtr; - - while (link->deleteProc == DeleteImportedCmd) { - ImportedCmdData *dataPtr; - - dataPtr = (ImportedCmdData *) link->objClientData; - link = dataPtr->realCmdPtr; - if (overwrite == link) { - Tcl_AppendResult(interp, "import pattern \"", pattern, - "\" would create a loop containing command \"", - Tcl_DStringValue(&ds), "\"", NULL); + Command *overwrite = Tcl_GetHashValue(found); + Command *linkCmd = cmdPtr; + + while (linkCmd->deleteProc == DeleteImportedCmd) { + dataPtr = linkCmd->objClientData; + linkCmd = dataPtr->realCmdPtr; + if (overwrite == linkCmd) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "import pattern \"%s\" would create a loop" + " containing command \"%s\"", + pattern, Tcl_DStringValue(&ds))); Tcl_DStringFree(&ds); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "LOOP", NULL); return TCL_ERROR; } } } - dataPtr = (ImportedCmdData *) ckalloc(sizeof(ImportedCmdData)); - importedCmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds), - InvokeImportedCmd, (ClientData) dataPtr, DeleteImportedCmd); + dataPtr = ckalloc(sizeof(ImportedCmdData)); + importedCmd = Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds), + InvokeImportedCmd, InvokeImportedNRCmd, dataPtr, + DeleteImportedCmd); dataPtr->realCmdPtr = cmdPtr; dataPtr->selfPtr = (Command *) importedCmd; dataPtr->selfPtr->compileProc = cmdPtr->compileProc; @@ -1614,23 +1740,27 @@ DoImport( * and add it to the import ref list in the "real" command. */ - refPtr = (ImportRef *) ckalloc(sizeof(ImportRef)); + refPtr = ckalloc(sizeof(ImportRef)); refPtr->importedCmdPtr = (Command *) importedCmd; refPtr->nextPtr = cmdPtr->importRefPtr; cmdPtr->importRefPtr = refPtr; } else { - Command *overwrite = (Command *) Tcl_GetHashValue(found); + Command *overwrite = Tcl_GetHashValue(found); if (overwrite->deleteProc == DeleteImportedCmd) { - ImportedCmdData *dataPtr = (ImportedCmdData *) - overwrite->objClientData; - if (dataPtr->realCmdPtr == (Command *) Tcl_GetHashValue(hPtr)) { - /* Repeated import of same command -- acceptable */ + ImportedCmdData *dataPtr = overwrite->objClientData; + + if (dataPtr->realCmdPtr == Tcl_GetHashValue(hPtr)) { + /* + * Repeated import of same command is acceptable. + */ + return TCL_OK; } } - Tcl_AppendResult(interp, "can't import command \"", cmdName, - "\": already exists", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't import command \"%s\": already exists", cmdName)); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "OVERWRITE", NULL); return TCL_ERROR; } return TCL_OK; @@ -1669,11 +1799,11 @@ Tcl_ForgetImport( Tcl_Namespace *namespacePtr,/* Points to the namespace from which * previously imported commands should be * removed. NULL for current namespace. */ - CONST char *pattern) /* String pattern indicating which imported + const char *pattern) /* String pattern indicating which imported * commands to remove. */ { Namespace *nsPtr, *sourceNsPtr, *dummyPtr; - CONST char *simplePattern; + const char *simplePattern; char *cmdName; register Tcl_HashEntry *hPtr; Tcl_HashSearch search; @@ -1683,7 +1813,7 @@ Tcl_ForgetImport( */ if (namespacePtr == NULL) { - nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + nsPtr = (Namespace *) TclGetCurrentNamespace(interp); } else { nsPtr = (Namespace *) namespacePtr; } @@ -1693,14 +1823,14 @@ Tcl_ForgetImport( * simple pattern. */ - TclGetNamespaceForQualName(interp, pattern, nsPtr, - /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY), + TclGetNamespaceForQualName(interp, pattern, nsPtr, TCL_NAMESPACE_ONLY, &sourceNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if (sourceNsPtr == NULL) { - Tcl_AppendResult(interp, - "unknown namespace in namespace forget pattern \"", - pattern, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown namespace in namespace forget pattern \"%s\"", + pattern)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, NULL); return TCL_ERROR; } @@ -1710,18 +1840,20 @@ Tcl_ForgetImport( */ if (TclMatchIsTrivial(simplePattern)) { - Command *cmdPtr; hPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern); - if ((hPtr != NULL) - && (cmdPtr = (Command *) Tcl_GetHashValue(hPtr)) - && (cmdPtr->deleteProc == DeleteImportedCmd)) { - Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); + if (hPtr != NULL) { + Command *cmdPtr = Tcl_GetHashValue(hPtr); + + if (cmdPtr && (cmdPtr->deleteProc == DeleteImportedCmd)) { + Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); + } } return TCL_OK; } for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); (hPtr != NULL); hPtr = Tcl_NextHashEntry(&search)) { - Command *cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + Command *cmdPtr = Tcl_GetHashValue(hPtr); + if (cmdPtr->deleteProc != DeleteImportedCmd) { continue; } @@ -1740,11 +1872,11 @@ Tcl_ForgetImport( for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); (hPtr != NULL); hPtr = Tcl_NextHashEntry(&search)) { Tcl_CmdInfo info; - Tcl_Command token = (Tcl_Command) Tcl_GetHashValue(hPtr); + Tcl_Command token = Tcl_GetHashValue(hPtr); Tcl_Command origin = TclGetOriginalCommand(token); if (Tcl_GetCommandInfoFromToken(origin, &info) == 0) { - continue; /* Not an imported command */ + continue; /* Not an imported command. */ } if (info.namespacePtr != (Tcl_Namespace *) sourceNsPtr) { /* @@ -1753,9 +1885,9 @@ Tcl_ForgetImport( */ Command *cmdPtr = (Command *) token; - ImportedCmdData *dataPtr = - (ImportedCmdData *) cmdPtr->objClientData; + ImportedCmdData *dataPtr = cmdPtr->objClientData; Tcl_Command firstToken = (Tcl_Command) dataPtr->realCmdPtr; + if (firstToken == origin) { continue; } @@ -1765,7 +1897,7 @@ Tcl_ForgetImport( } origin = firstToken; } - if (Tcl_StringMatch(Tcl_GetCommandName(NULL, origin), simplePattern)) { + if (Tcl_StringMatch(Tcl_GetCommandName(NULL, origin), simplePattern)){ Tcl_DeleteCommandFromToken(interp, token); } } @@ -1804,11 +1936,11 @@ TclGetOriginalCommand( ImportedCmdData *dataPtr; if (cmdPtr->deleteProc != DeleteImportedCmd) { - return (Tcl_Command) NULL; + return NULL; } while (cmdPtr->deleteProc == DeleteImportedCmd) { - dataPtr = (ImportedCmdData *) cmdPtr->objClientData; + dataPtr = cmdPtr->objClientData; cmdPtr = dataPtr->realCmdPtr; } return (Tcl_Command) cmdPtr; @@ -1834,17 +1966,29 @@ TclGetOriginalCommand( */ static int -InvokeImportedCmd( +InvokeImportedNRCmd( ClientData clientData, /* Points to the imported command's * ImportedCmdData structure. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* The argument objects. */ + Tcl_Obj *const objv[]) /* The argument objects. */ { - register ImportedCmdData *dataPtr = (ImportedCmdData *) clientData; - register Command *realCmdPtr = dataPtr->realCmdPtr; + ImportedCmdData *dataPtr = clientData; + Command *realCmdPtr = dataPtr->realCmdPtr; - return (*realCmdPtr->objProc)(realCmdPtr->objClientData, interp, + TclSkipTailcall(interp); + return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NOERR, realCmdPtr); +} + +static int +InvokeImportedCmd( + ClientData clientData, /* Points to the imported command's + * ImportedCmdData structure. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* The argument objects. */ +{ + return Tcl_NRCallObjProc(interp, InvokeImportedNRCmd, clientData, objc, objv); } @@ -1874,7 +2018,7 @@ DeleteImportedCmd( ClientData clientData) /* Points to the imported command's * ImportedCmdData structure. */ { - ImportedCmdData *dataPtr = (ImportedCmdData *) clientData; + ImportedCmdData *dataPtr = clientData; Command *realCmdPtr = dataPtr->realCmdPtr; Command *selfPtr = dataPtr->selfPtr; register ImportRef *refPtr, *prevPtr; @@ -1888,13 +2032,13 @@ DeleteImportedCmd( * that refer to it. */ - if (prevPtr == NULL) { /* refPtr is first in list */ + if (prevPtr == NULL) { /* refPtr is first in list. */ realCmdPtr->importRefPtr = refPtr->nextPtr; } else { prevPtr->nextPtr = refPtr->nextPtr; } - ckfree((char *) refPtr); - ckfree((char *) dataPtr); + ckfree(refPtr); + ckfree(dataPtr); return; } prevPtr = refPtr; @@ -1985,7 +2129,7 @@ int TclGetNamespaceForQualName( Tcl_Interp *interp, /* Interpreter in which to find the namespace * containing qualName. */ - CONST char *qualName, /* A namespace-qualified name of an command, + const char *qualName, /* A namespace-qualified name of an command, * variable, or namespace. */ Namespace *cxtNsPtr, /* The namespace in which to start the search * for qualName's namespace. If NULL start @@ -2014,7 +2158,7 @@ TclGetNamespaceForQualName( * namespace if TCL_GLOBAL_ONLY was specified, * or the current namespace if cxtNsPtr was * NULL. */ - CONST char **simpleNamePtr) /* Address where function stores the simple + const char **simpleNamePtr) /* Address where function stores the simple * name at end of the qualName, or NULL if * qualName is "::" or the flag * TCL_FIND_ONLY_NS was specified. */ @@ -2023,8 +2167,8 @@ TclGetNamespaceForQualName( Namespace *nsPtr = cxtNsPtr; Namespace *altNsPtr; Namespace *globalNsPtr = iPtr->globalNsPtr; - CONST char *start, *end; - CONST char *nsName; + const char *start, *end; + const char *nsName; Tcl_HashEntry *entryPtr; Tcl_DString buffer; int len; @@ -2041,25 +2185,23 @@ TclGetNamespaceForQualName( if (flags & TCL_GLOBAL_ONLY) { nsPtr = globalNsPtr; } else if (nsPtr == NULL) { - if (iPtr->varFramePtr != NULL) { - nsPtr = iPtr->varFramePtr->nsPtr; - } else { - nsPtr = iPtr->globalNsPtr; - } + nsPtr = iPtr->varFramePtr->nsPtr; } - start = qualName; /* pts to start of qualifying namespace */ + start = qualName; /* Points to start of qualifying + * namespace. */ if ((*qualName == ':') && (*(qualName+1) == ':')) { - start = qualName+2; /* skip over the initial :: */ + start = qualName+2; /* Skip over the initial :: */ while (*start == ':') { - start++; /* skip over a subsequent : */ + start++; /* Skip over a subsequent : */ } nsPtr = globalNsPtr; - if (*start == '\0') { /* qualName is just two or more ":"s */ + if (*start == '\0') { /* qualName is just two or more + * ":"s. */ *nsPtrPtr = globalNsPtr; *altNsPtrPtr = NULL; *actualCxtPtrPtr = globalNsPtr; - *simpleNamePtr = start; /* points to empty string */ + *simpleNamePtr = start; /* Points to empty string. */ return TCL_OK; } } @@ -2095,11 +2237,11 @@ TclGetNamespaceForQualName( len = 0; for (end = start; *end != '\0'; end++) { if ((*end == ':') && (*(end+1) == ':')) { - end += 2; /* skip over the initial :: */ + end += 2; /* Skip over the initial :: */ while (*end == ':') { - end++; /* skip over the subsequent : */ + end++; /* Skip over the subsequent : */ } - break; /* exit for loop; end is after ::'s */ + break; /* Exit for loop; end is after ::'s */ } len++; } @@ -2129,7 +2271,7 @@ TclGetNamespaceForQualName( * qualName since it may be a string constant. */ - Tcl_DStringSetLength(&buffer, 0); + TclDStringClear(&buffer); Tcl_DStringAppend(&buffer, start, len); nsName = Tcl_DStringValue(&buffer); } @@ -2142,23 +2284,32 @@ TclGetNamespaceForQualName( */ if (nsPtr != NULL) { +#ifndef BREAK_NAMESPACE_COMPAT entryPtr = Tcl_FindHashEntry(&nsPtr->childTable, nsName); +#else + if (nsPtr->childTablePtr == NULL) { + entryPtr = NULL; + } else { + entryPtr = Tcl_FindHashEntry(nsPtr->childTablePtr, nsName); + } +#endif if (entryPtr != NULL) { - nsPtr = (Namespace *) Tcl_GetHashValue(entryPtr); + nsPtr = Tcl_GetHashValue(entryPtr); } else if (flags & TCL_CREATE_NS_IF_UNKNOWN) { Tcl_CallFrame *framePtr; (void) TclPushStackFrame(interp, &framePtr, (Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 0); - nsPtr = (Namespace *) Tcl_CreateNamespace(interp, nsName, - (ClientData) NULL, NULL); + nsPtr = (Namespace *) + Tcl_CreateNamespace(interp, nsName, NULL, NULL); TclPopStackFrame(interp); if (nsPtr == NULL) { Tcl_Panic("Could not create namespace '%s'", nsName); } - } else { /* namespace not found and wasn't created */ + } else { /* Namespace not found and was not + * created. */ nsPtr = NULL; } } @@ -2168,9 +2319,17 @@ TclGetNamespaceForQualName( */ if (altNsPtr != NULL) { +#ifndef BREAK_NAMESPACE_COMPAT entryPtr = Tcl_FindHashEntry(&altNsPtr->childTable, nsName); +#else + if (altNsPtr->childTablePtr != NULL) { + entryPtr = Tcl_FindHashEntry(altNsPtr->childTablePtr, nsName); + } else { + entryPtr = NULL; + } +#endif if (entryPtr != NULL) { - altNsPtr = (Namespace *) Tcl_GetHashValue(entryPtr); + altNsPtr = Tcl_GetHashValue(entryPtr); } else { altNsPtr = NULL; } @@ -2197,9 +2356,10 @@ TclGetNamespaceForQualName( */ if ((flags & TCL_FIND_ONLY_NS) || (end>start && *(end-1)!=':')) { - *simpleNamePtr = NULL; /* found namespace name */ + *simpleNamePtr = NULL; /* Found namespace name. */ } else { - *simpleNamePtr = end; /* found cmd/var: points to empty string */ + *simpleNamePtr = end; /* Found cmd/var: points to empty + * string. */ } /* @@ -2242,7 +2402,7 @@ Tcl_Namespace * Tcl_FindNamespace( Tcl_Interp *interp, /* The interpreter in which to find the * namespace. */ - CONST char *name, /* Namespace name. If it starts with "::", + const char *name, /* Namespace name. If it starts with "::", * will be looked up in global namespace. * Else, looked up first in contextNsPtr * (current namespace if contextNsPtr is @@ -2257,7 +2417,7 @@ Tcl_FindNamespace( * TCL_LEAVE_ERR_MSG flags. */ { Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr; - CONST char *dummy; + const char *dummy; /* * Find the namespace(s) that contain the specified namespace name. Add @@ -2270,9 +2430,12 @@ Tcl_FindNamespace( if (nsPtr != NULL) { return (Tcl_Namespace *) nsPtr; - } else if (flags & TCL_LEAVE_ERR_MSG) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "unknown namespace \"", name, "\"", NULL); + } + + if (flags & TCL_LEAVE_ERR_MSG) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown namespace \"%s\"", name)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", name, NULL); } return NULL; } @@ -2300,7 +2463,7 @@ Tcl_Command Tcl_FindCommand( Tcl_Interp *interp, /* The interpreter in which to find the * command and to report errors. */ - CONST char *name, /* Command's name. If it starts with "::", + const char *name, /* Command's name. If it starts with "::", * will be looked up in global namespace. * Else, looked up first in contextNsPtr * (current namespace if contextNsPtr is @@ -2318,11 +2481,11 @@ Tcl_FindCommand( * and TCL_NAMESPACE_ONLY are given, * TCL_GLOBAL_ONLY is ignored. */ { - Interp *iPtr = (Interp*)interp; + Interp *iPtr = (Interp *) interp; Namespace *cxtNsPtr; register Tcl_HashEntry *entryPtr; register Command *cmdPtr; - CONST char *simpleName; + const char *simpleName; int result; /* @@ -2333,12 +2496,12 @@ Tcl_FindCommand( * signal an error. */ - if (flags & TCL_GLOBAL_ONLY) { - cxtNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); + if ((flags & TCL_GLOBAL_ONLY) || !strncmp(name, "::", 2)) { + cxtNsPtr = (Namespace *) TclGetGlobalNamespace(interp); } else if (contextNsPtr != NULL) { cxtNsPtr = (Namespace *) contextNsPtr; } else { - cxtNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + cxtNsPtr = (Namespace *) TclGetCurrentNamespace(interp); } if (cxtNsPtr->cmdResProc != NULL || iPtr->resolverPtr != NULL) { @@ -2346,7 +2509,7 @@ Tcl_FindCommand( Tcl_Command cmd; if (cxtNsPtr->cmdResProc) { - result = (*cxtNsPtr->cmdResProc)(interp, name, + result = cxtNsPtr->cmdResProc(interp, name, (Tcl_Namespace *) cxtNsPtr, flags, &cmd); } else { result = TCL_CONTINUE; @@ -2354,7 +2517,7 @@ Tcl_FindCommand( while (result == TCL_CONTINUE && resPtr) { if (resPtr->cmdResProc) { - result = (*resPtr->cmdResProc)(interp, name, + result = resPtr->cmdResProc(interp, name, (Tcl_Namespace *) cxtNsPtr, flags, &cmd); } resPtr = resPtr->nextPtr; @@ -2363,7 +2526,7 @@ Tcl_FindCommand( if (result == TCL_OK) { return cmd; } else if (result != TCL_CONTINUE) { - return (Tcl_Command) NULL; + return NULL; } } @@ -2372,7 +2535,8 @@ Tcl_FindCommand( */ cmdPtr = NULL; - if (cxtNsPtr->commandPathLength!=0 && strncmp(name, "::", 2)) { + if (cxtNsPtr->commandPathLength!=0 && strncmp(name, "::", 2) + && !(flags & TCL_NAMESPACE_ONLY)) { int i; Namespace *pathNsPtr, *realNsPtr, *dummyNsPtr; @@ -2381,10 +2545,10 @@ Tcl_FindCommand( &simpleName); if ((realNsPtr != NULL) && (simpleName != NULL)) { if ((cxtNsPtr == realNsPtr) - || !(realNsPtr->flags & (NS_DEAD|NS_DYING))) { + || !(realNsPtr->flags & NS_DYING)) { entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName); if (entryPtr != NULL) { - cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); + cmdPtr = Tcl_GetHashValue(entryPtr); } } } @@ -2402,10 +2566,10 @@ Tcl_FindCommand( TCL_NAMESPACE_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr, &simpleName); if ((realNsPtr != NULL) && (simpleName != NULL) - && !(realNsPtr->flags & (NS_DEAD|NS_DYING))) { + && !(realNsPtr->flags & NS_DYING)) { entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName); if (entryPtr != NULL) { - cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); + cmdPtr = Tcl_GetHashValue(entryPtr); } } } @@ -2420,10 +2584,10 @@ Tcl_FindCommand( TCL_GLOBAL_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr, &simpleName); if ((realNsPtr != NULL) && (simpleName != NULL) - && !(realNsPtr->flags & (NS_DEAD|NS_DYING))) { + && !(realNsPtr->flags & NS_DYING)) { entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName); if (entryPtr != NULL) { - cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); + cmdPtr = Tcl_GetHashValue(entryPtr); } } } @@ -2445,7 +2609,7 @@ Tcl_FindCommand( entryPtr = Tcl_FindHashEntry(&nsPtr[search]->cmdTable, simpleName); if (entryPtr != NULL) { - cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); + cmdPtr = Tcl_GetHashValue(entryPtr); } } } @@ -2456,133 +2620,11 @@ Tcl_FindCommand( } if (flags & TCL_LEAVE_ERR_MSG) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "unknown command \"", name, "\"", NULL); - } - return (Tcl_Command) NULL; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_FindNamespaceVar -- - * - * Searches for a namespace variable, a variable not local to a - * procedure. The variable can be either a scalar or an array, but may - * not be an element of an array. - * - * Results: - * Returns a token for the variable if it is found. Otherwise, if it - * can't be found or there is an error, returns NULL and leaves an error - * message in the interpreter's result object if "flags" contains - * TCL_LEAVE_ERR_MSG. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -Tcl_Var -Tcl_FindNamespaceVar( - Tcl_Interp *interp, /* The interpreter in which to find the - * variable. */ - CONST char *name, /* Variable's name. If it starts with "::", - * will be looked up in global namespace. - * Else, looked up first in contextNsPtr - * (current namespace if contextNsPtr is - * NULL), then in global namespace. */ - Tcl_Namespace *contextNsPtr,/* Ignored if TCL_GLOBAL_ONLY flag set. - * Otherwise, points to namespace in which to - * resolve name. If NULL, look up name in the - * current namespace. */ - int flags) /* An OR'd combination of flags: - * TCL_GLOBAL_ONLY (look up name only in - * global namespace), TCL_NAMESPACE_ONLY (look - * up only in contextNsPtr, or the current - * namespace if contextNsPtr is NULL), and - * TCL_LEAVE_ERR_MSG. If both TCL_GLOBAL_ONLY - * and TCL_NAMESPACE_ONLY are given, - * TCL_GLOBAL_ONLY is ignored. */ -{ - Interp *iPtr = (Interp*)interp; - ResolverScheme *resPtr; - Namespace *nsPtr[2], *cxtNsPtr; - CONST char *simpleName; - Tcl_HashEntry *entryPtr; - Var *varPtr; - register int search; - int result; - Tcl_Var var; - - /* - * If this namespace has a variable resolver, then give it first crack at - * the variable resolution. It may return a Tcl_Var value, it may signal - * to continue onward, or it may signal an error. - */ - - if ((flags & TCL_GLOBAL_ONLY) != 0) { - cxtNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); - } else if (contextNsPtr != NULL) { - cxtNsPtr = (Namespace *) contextNsPtr; - } else { - cxtNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); - } - - if (cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) { - resPtr = iPtr->resolverPtr; - - if (cxtNsPtr->varResProc) { - result = (*cxtNsPtr->varResProc)(interp, name, - (Tcl_Namespace *) cxtNsPtr, flags, &var); - } else { - result = TCL_CONTINUE; - } - - while (result == TCL_CONTINUE && resPtr) { - if (resPtr->varResProc) { - result = (*resPtr->varResProc)(interp, name, - (Tcl_Namespace *) cxtNsPtr, flags, &var); - } - resPtr = resPtr->nextPtr; - } - - if (result == TCL_OK) { - return var; - } else if (result != TCL_CONTINUE) { - return (Tcl_Var) NULL; - } - } - - /* - * Find the namespace(s) that contain the variable. - */ - - TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, - flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName); - - /* - * Look for the variable in the variable table of its namespace. Be sure - * to check both possible search paths: from the specified namespace - * context and from the global namespace. - */ - - varPtr = NULL; - for (search = 0; (search < 2) && (varPtr == NULL); search++) { - if ((nsPtr[search] != NULL) && (simpleName != NULL)) { - entryPtr = Tcl_FindHashEntry(&nsPtr[search]->varTable, simpleName); - if (entryPtr != NULL) { - varPtr = (Var *) Tcl_GetHashValue(entryPtr); - } - } - } - if (varPtr != NULL) { - return (Tcl_Var) varPtr; - } else if (flags & TCL_LEAVE_ERR_MSG) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "unknown variable \"", name, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown command \"%s\"", name)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", name, NULL); } - return (Tcl_Var) NULL; + return NULL; } /* @@ -2626,19 +2668,12 @@ TclResetShadowedCmdRefs( Tcl_HashEntry *hPtr; register Namespace *nsPtr; Namespace *trailNsPtr, *shadowNsPtr; - Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); + Namespace *globalNsPtr = (Namespace *) TclGetGlobalNamespace(interp); int found, i; - - /* - * This function generates an array used to hold the trail list. This - * starts out with stack-allocated space but uses dynamically-allocated - * storage if needed. - */ - - Namespace *(trailStorage[NUM_TRAIL_ELEMS]); - Namespace **trailPtr = trailStorage; int trailFront = -1; - int trailSize = NUM_TRAIL_ELEMS; + int trailSize = 5; /* Formerly NUM_TRAIL_ELEMS. */ + Namespace **trailPtr = TclStackAlloc(interp, + trailSize * sizeof(Namespace *)); /* * Start at the namespace containing the new command, and work up through @@ -2674,10 +2709,19 @@ TclResetShadowedCmdRefs( for (i = trailFront; i >= 0; i--) { trailNsPtr = trailPtr[i]; +#ifndef BREAK_NAMESPACE_COMPAT hPtr = Tcl_FindHashEntry(&shadowNsPtr->childTable, trailNsPtr->name); +#else + if (shadowNsPtr->childTablePtr != NULL) { + hPtr = Tcl_FindHashEntry(shadowNsPtr->childTablePtr, + trailNsPtr->name); + } else { + hPtr = NULL; + } +#endif if (hPtr != NULL) { - shadowNsPtr = (Namespace *) Tcl_GetHashValue(hPtr); + shadowNsPtr = Tcl_GetHashValue(hPtr); } else { found = 0; break; @@ -2703,7 +2747,7 @@ TclResetShadowedCmdRefs( * for a fresh compilation of every bytecode. */ - if (((Command *)Tcl_GetHashValue(hPtr))->compileProc != NULL) { + if (((Command *)Tcl_GetHashValue(hPtr))->compileProc != NULL){ nsPtr->resolverEpoch++; } } @@ -2716,52 +2760,36 @@ TclResetShadowedCmdRefs( trailFront++; if (trailFront == trailSize) { - size_t currBytes = trailSize * sizeof(Namespace *); - int newSize = 2*trailSize; - size_t newBytes = newSize * sizeof(Namespace *); - Namespace **newPtr = (Namespace **) ckalloc((unsigned) newBytes); - - memcpy((void *) newPtr, (void *) trailPtr, currBytes); - if (trailPtr != trailStorage) { - ckfree((char *) trailPtr); - } - trailPtr = newPtr; + int newSize = 2 * trailSize; + + trailPtr = TclStackRealloc(interp, trailPtr, + newSize * sizeof(Namespace *)); trailSize = newSize; } trailPtr[trailFront] = nsPtr; } - - /* - * Free any allocated storage. - */ - - if (trailPtr != trailStorage) { - ckfree((char *) trailPtr); - } + TclStackFree(interp, trailPtr); } /* *---------------------------------------------------------------------- * - * TclGetNamespaceFromObj -- + * TclGetNamespaceFromObj, GetNamespaceFromObj -- * * Gets the namespace specified by the name in a Tcl_Obj. * * Results: * Returns TCL_OK if the namespace was resolved successfully, and stores * a pointer to the namespace in the location specified by nsPtrPtr. If - * the namespace can't be found, the function stores NULL in *nsPtrPtr - * and returns TCL_OK. If anything else goes wrong, this function returns - * TCL_ERROR. + * the namespace can't be found, or anything else goes wrong, this + * function returns TCL_ERROR and writes an error message to interp, + * if non-NULL. * * Side effects: * May update the internal representation for the object, caching the * namespace reference. The next time this function is called, the * namespace value can be found quickly. * - * If anything goes wrong, an error message is left in the interpreter's - * result object. - * *---------------------------------------------------------------------- */ @@ -2772,209 +2800,84 @@ TclGetNamespaceFromObj( * namespace. */ Tcl_Namespace **nsPtrPtr) /* Result namespace pointer goes here. */ { - Interp *iPtr = (Interp *) interp; - register ResolvedNsName *resNamePtr; - register Namespace *nsPtr; - Namespace *currNsPtr; - CallFrame *savedFramePtr; - int result = TCL_OK; - char *name; - - /* - * If the namespace name is fully qualified, do as if the lookup were done - * from the global namespace; this helps avoid repeated lookups of fully - * qualified names. - */ + if (GetNamespaceFromObj(interp, objPtr, nsPtrPtr) == TCL_ERROR) { + const char *name = TclGetString(objPtr); - savedFramePtr = iPtr->varFramePtr; - name = TclGetString(objPtr); - if ((*name++ == ':') && (*name == ':')) { - iPtr->varFramePtr = NULL; - } - - currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); - - /* - * Get the internal representation, converting to a namespace type if - * needed. The internal representation is a ResolvedNsName that points to - * the actual namespace. - */ + if ((name[0] == ':') && (name[1] == ':')) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "namespace \"%s\" not found", name)); + } else { + /* + * Get the current namespace name. + */ - if (objPtr->typePtr != &tclNsNameType) { - result = tclNsNameType.setFromAnyProc(interp, objPtr); - if (result != TCL_OK) { - goto done; + NamespaceCurrentCmd(NULL, interp, 1, NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "namespace \"%s\" not found in \"%s\"", name, + Tcl_GetStringResult(interp))); } + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", name, NULL); + return TCL_ERROR; } - resNamePtr = (ResolvedNsName *) objPtr->internalRep.otherValuePtr; + return TCL_OK; +} - /* - * Check the context namespace of the resolved symbol to make sure that it - * is fresh. If not, then force another conversion to the namespace type, - * to discard the old rep and create a new one. Note that we verify that - * the namespace id of the cached namespace is the same as the id when we - * cached it; this insures that the namespace wasn't deleted and a new one - * created at the same address. - */ +static int +GetNamespaceFromObj( + Tcl_Interp *interp, /* The current interpreter. */ + Tcl_Obj *objPtr, /* The object to be resolved as the name of a + * namespace. */ + Tcl_Namespace **nsPtrPtr) /* Result namespace pointer goes here. */ +{ + ResolvedNsName *resNamePtr; + Namespace *nsPtr, *refNsPtr; + + if (objPtr->typePtr == &nsNameType) { + /* + * Check that the ResolvedNsName is still valid; avoid letting the ref + * cross interps. + */ - nsPtr = NULL; - if ((resNamePtr != NULL) && (resNamePtr->refNsPtr == currNsPtr) - && (resNamePtr->nsId == resNamePtr->nsPtr->nsId)) { + resNamePtr = objPtr->internalRep.twoPtrValue.ptr1; nsPtr = resNamePtr->nsPtr; - if (nsPtr->flags & NS_DEAD) { - nsPtr = NULL; + refNsPtr = resNamePtr->refNsPtr; + if (!(nsPtr->flags & NS_DYING) && (interp == nsPtr->interp) && + (!refNsPtr || ((interp == refNsPtr->interp) && + (refNsPtr== (Namespace *) Tcl_GetCurrentNamespace(interp))))){ + *nsPtrPtr = (Tcl_Namespace *) nsPtr; + return TCL_OK; } } - if (nsPtr == NULL) { /* try again */ - result = tclNsNameType.setFromAnyProc(interp, objPtr); - if (result != TCL_OK) { - goto done; - } - resNamePtr = (ResolvedNsName *) objPtr->internalRep.otherValuePtr; - if (resNamePtr != NULL) { - nsPtr = resNamePtr->nsPtr; - if (nsPtr->flags & NS_DEAD) { - nsPtr = NULL; - } - } + if (SetNsNameFromAny(interp, objPtr) == TCL_OK) { + resNamePtr = objPtr->internalRep.twoPtrValue.ptr1; + *nsPtrPtr = (Tcl_Namespace *) resNamePtr->nsPtr; + return TCL_OK; } - *nsPtrPtr = (Tcl_Namespace *) nsPtr; - - done: - iPtr->varFramePtr = savedFramePtr; - return result; + return TCL_ERROR; } /* *---------------------------------------------------------------------- * - * Tcl_NamespaceObjCmd -- + * TclInitNamespaceCmd -- * - * Invoked to implement the "namespace" command that creates, deletes, or - * manipulates Tcl namespaces. Handles the following syntax: - * - * namespace children ?name? ?pattern? - * namespace code arg - * namespace current - * namespace delete ?name name...? - * namespace ensemble subcommand ?arg...? - * namespace eval name arg ?arg...? - * namespace exists name - * namespace export ?-clear? ?pattern pattern...? - * namespace forget ?pattern pattern...? - * namespace import ?-force? ?pattern pattern...? - * namespace inscope name arg ?arg...? - * namespace origin name - * namespace parent ?name? - * namespace qualifiers string - * namespace tail string - * namespace which ?-command? ?-variable? name + * This function is called to create the "namespace" Tcl command. See the + * user documentation for details on what it does. * * Results: - * Returns TCL_OK if the command is successful. Returns TCL_ERROR if - * anything goes wrong. + * Handle for the namespace command, or NULL on failure. * * Side effects: - * Based on the subcommand name (e.g., "import"), this function - * dispatches to a corresponding function NamespaceXXXCmd defined - * statically in this file. This function's side effects depend on - * whatever that subcommand function does. If there is an error, this - * function returns an error message in the interpreter's result object. - * Otherwise it may return a result in the interpreter's result object. + * none * *---------------------------------------------------------------------- */ -int -Tcl_NamespaceObjCmd( - ClientData clientData, /* Arbitrary value passed to cmd. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ +Tcl_Command +TclInitNamespaceCmd( + Tcl_Interp *interp) /* Current interpreter. */ { - static CONST char *subCmds[] = { - "children", "code", "current", "delete", "ensemble", - "eval", "exists", "export", "forget", "import", - "inscope", "origin", "parent", "path", "qualifiers", - "tail", "which", NULL - }; - enum NSSubCmdIdx { - NSChildrenIdx, NSCodeIdx, NSCurrentIdx, NSDeleteIdx, NSEnsembleIdx, - NSEvalIdx, NSExistsIdx, NSExportIdx, NSForgetIdx, NSImportIdx, - NSInscopeIdx, NSOriginIdx, NSParentIdx, NSPathIdx, NSQualifiersIdx, - NSTailIdx, NSWhichIdx - }; - int index, result; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?"); - return TCL_ERROR; - } - - /* - * Return an index reflecting the particular subcommand. - */ - - result = Tcl_GetIndexFromObj((Tcl_Interp *) interp, objv[1], subCmds, - "option", /*flags*/ 0, (int *) &index); - if (result != TCL_OK) { - return result; - } - - switch (index) { - case NSChildrenIdx: - result = NamespaceChildrenCmd(clientData, interp, objc, objv); - break; - case NSCodeIdx: - result = NamespaceCodeCmd(clientData, interp, objc, objv); - break; - case NSCurrentIdx: - result = NamespaceCurrentCmd(clientData, interp, objc, objv); - break; - case NSDeleteIdx: - result = NamespaceDeleteCmd(clientData, interp, objc, objv); - break; - case NSEnsembleIdx: - result = NamespaceEnsembleCmd(clientData, interp, objc, objv); - break; - case NSEvalIdx: - result = NamespaceEvalCmd(clientData, interp, objc, objv); - break; - case NSExistsIdx: - result = NamespaceExistsCmd(clientData, interp, objc, objv); - break; - case NSExportIdx: - result = NamespaceExportCmd(clientData, interp, objc, objv); - break; - case NSForgetIdx: - result = NamespaceForgetCmd(clientData, interp, objc, objv); - break; - case NSImportIdx: - result = NamespaceImportCmd(clientData, interp, objc, objv); - break; - case NSInscopeIdx: - result = NamespaceInscopeCmd(clientData, interp, objc, objv); - break; - case NSOriginIdx: - result = NamespaceOriginCmd(clientData, interp, objc, objv); - break; - case NSParentIdx: - result = NamespaceParentCmd(clientData, interp, objc, objv); - break; - case NSPathIdx: - result = NamespacePathCmd(clientData, interp, objc, objv); - break; - case NSQualifiersIdx: - result = NamespaceQualifiersCmd(clientData, interp, objc, objv); - break; - case NSTailIdx: - result = NamespaceTailCmd(clientData, interp, objc, objv); - break; - case NSWhichIdx: - result = NamespaceWhichCmd(clientData, interp, objc, objv); - break; - } - return result; + return TclMakeEnsemble(interp, "namespace", defaultNamespaceMap); } /* @@ -3003,12 +2906,12 @@ NamespaceChildrenCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Namespace *namespacePtr; Namespace *nsPtr, *childNsPtr; - Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); - char *pattern = NULL; + Namespace *globalNsPtr = (Namespace *) TclGetGlobalNamespace(interp); + const char *pattern = NULL; Tcl_DString buffer; register Tcl_HashEntry *entryPtr; Tcl_HashSearch search; @@ -3018,21 +2921,15 @@ NamespaceChildrenCmd( * Get a pointer to the specified namespace, or the current namespace. */ - if (objc == 2) { - nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); - } else if ((objc == 3) || (objc == 4)) { - if (TclGetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) { - return TCL_ERROR; - } - if (namespacePtr == NULL) { - Tcl_AppendResult(interp, "unknown namespace \"", - TclGetString(objv[2]), - "\" in namespace children command", NULL); + if (objc == 1) { + nsPtr = (Namespace *) TclGetCurrentNamespace(interp); + } else if ((objc == 2) || (objc == 3)) { + if (TclGetNamespaceFromObj(interp, objv[1], &namespacePtr) != TCL_OK){ return TCL_ERROR; } nsPtr = (Namespace *) namespacePtr; } else { - Tcl_WrongNumArgs(interp, 2, objv, "?name? ?pattern?"); + Tcl_WrongNumArgs(interp, 1, objv, "?name? ?pattern?"); return TCL_ERROR; } @@ -3041,15 +2938,15 @@ NamespaceChildrenCmd( */ Tcl_DStringInit(&buffer); - if (objc == 4) { - char *name = TclGetString(objv[3]); + if (objc == 3) { + const char *name = TclGetString(objv[2]); if ((*name == ':') && (*(name+1) == ':')) { pattern = name; } else { Tcl_DStringAppend(&buffer, nsPtr->fullName, -1); if (nsPtr != globalNsPtr) { - Tcl_DStringAppend(&buffer, "::", 2); + TclDStringAppendLiteral(&buffer, "::"); } Tcl_DStringAppend(&buffer, name, -1); pattern = Tcl_DStringValue(&buffer); @@ -3063,15 +2960,34 @@ NamespaceChildrenCmd( listPtr = Tcl_NewListObj(0, NULL); if ((pattern != NULL) && TclMatchIsTrivial(pattern)) { - if (Tcl_FindHashEntry(&nsPtr->childTable, pattern) != NULL) { + unsigned int length = strlen(nsPtr->fullName); + + if (strncmp(pattern, nsPtr->fullName, length) != 0) { + goto searchDone; + } + if ( +#ifndef BREAK_NAMESPACE_COMPAT + Tcl_FindHashEntry(&nsPtr->childTable, pattern+length) != NULL +#else + nsPtr->childTablePtr != NULL && + Tcl_FindHashEntry(nsPtr->childTablePtr, pattern+length) != NULL +#endif + ) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(pattern, -1)); } goto searchDone; } +#ifndef BREAK_NAMESPACE_COMPAT entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); +#else + if (nsPtr->childTablePtr == NULL) { + goto searchDone; + } + entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search); +#endif while (entryPtr != NULL) { - childNsPtr = (Namespace *) Tcl_GetHashValue(entryPtr); + childNsPtr = Tcl_GetHashValue(entryPtr); if ((pattern == NULL) || Tcl_StringMatch(childNsPtr->fullName, pattern)) { elemPtr = Tcl_NewStringObj(childNsPtr->fullName, -1); @@ -3119,35 +3035,31 @@ NamespaceCodeCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { Namespace *currNsPtr; Tcl_Obj *listPtr, *objPtr; - register char *arg, *p; + register const char *arg; int length; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "arg"); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "arg"); return TCL_ERROR; } /* * If "arg" is already a scoped value, then return it directly. + * Take care to only check for scoping in precisely the style that + * [::namespace code] generates it. Anything more forgiving can have + * the effect of failing in namespaces that contain their own custom + " "namespace" command. [Bug 3202171]. */ - arg = Tcl_GetStringFromObj(objv[2], &length); - while (*arg == ':') { - arg++; - length--; - } - if (*arg=='n' && length>17 && strncmp(arg, "namespace", 9)==0) { - for (p=arg+9 ; isspace(UCHAR(*p)) ; p++) { - /* empty body: skip over whitespace */ - } - if (*p=='i' && (p+7 <= arg+length) && strncmp(p, "inscope", 7)==0) { - Tcl_SetObjResult(interp, objv[2]); - return TCL_OK; - } + arg = TclGetStringFromObj(objv[1], &length); + if (*arg==':' && length > 20 + && strncmp(arg, "::namespace inscope ", 20) == 0) { + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; } /* @@ -3158,21 +3070,21 @@ NamespaceCodeCmd( * "namespace inscope" command. */ - listPtr = Tcl_NewListObj(0, NULL); - Tcl_ListObjAppendElement(interp, listPtr, - Tcl_NewStringObj("::namespace", -1)); - Tcl_ListObjAppendElement(interp, listPtr, - Tcl_NewStringObj("inscope", -1)); - - currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); - if (currNsPtr == (Namespace *) Tcl_GetGlobalNamespace(interp)) { - objPtr = Tcl_NewStringObj("::", -1); + TclNewObj(listPtr); + TclNewLiteralStringObj(objPtr, "::namespace"); + Tcl_ListObjAppendElement(interp, listPtr, objPtr); + TclNewLiteralStringObj(objPtr, "inscope"); + Tcl_ListObjAppendElement(interp, listPtr, objPtr); + + currNsPtr = (Namespace *) TclGetCurrentNamespace(interp); + if (currNsPtr == (Namespace *) TclGetGlobalNamespace(interp)) { + TclNewLiteralStringObj(objPtr, "::"); } else { objPtr = Tcl_NewStringObj(currNsPtr->fullName, -1); } Tcl_ListObjAppendElement(interp, listPtr, objPtr); - Tcl_ListObjAppendElement(interp, listPtr, objv[2]); + Tcl_ListObjAppendElement(interp, listPtr, objv[1]); Tcl_SetObjResult(interp, listPtr); return TCL_OK; @@ -3204,12 +3116,12 @@ NamespaceCurrentCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { register Namespace *currNsPtr; - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } @@ -3222,8 +3134,8 @@ NamespaceCurrentCmd( * namespace [namespace current]::bar { ... } */ - currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); - if (currNsPtr == (Namespace *) Tcl_GetGlobalNamespace(interp)) { + currNsPtr = (Namespace *) TclGetCurrentNamespace(interp); + if (currNsPtr == (Namespace *) TclGetGlobalNamespace(interp)) { Tcl_SetObjResult(interp, Tcl_NewStringObj("::", 2)); } else { Tcl_SetObjResult(interp, Tcl_NewStringObj(currNsPtr->fullName, -1)); @@ -3267,31 +3179,33 @@ NamespaceDeleteCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Namespace *namespacePtr; - char *name; + const char *name; register int i; - if (objc < 2) { - Tcl_WrongNumArgs(interp, 2, objv, "?name name...?"); + if (objc < 1) { + Tcl_WrongNumArgs(interp, 1, objv, "?name name...?"); return TCL_ERROR; } /* * Destroying one namespace may cause another to be destroyed. Break this * into two passes: first check to make sure that all namespaces on the - * command line are valid, and report any errors. + * command line are valid, and report any errors. */ - for (i = 2; i < objc; i++) { + for (i = 1; i < objc; i++) { name = TclGetString(objv[i]); namespacePtr = Tcl_FindNamespace(interp, name, NULL, /*flags*/ 0); if ((namespacePtr == NULL) - || (((Namespace *)namespacePtr)->flags & NS_KILLED)) { - Tcl_AppendResult(interp, "unknown namespace \"", - TclGetString(objv[i]), - "\" in namespace delete command", NULL); + || (((Namespace *) namespacePtr)->flags & NS_KILLED)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown namespace \"%s\" in namespace delete command", + TclGetString(objv[i]))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", + TclGetString(objv[i]), NULL); return TCL_ERROR; } } @@ -3300,7 +3214,7 @@ NamespaceDeleteCmd( * Okay, now delete each namespace. */ - for (i = 2; i < objc; i++) { + for (i = 1; i < objc; i++) { name = TclGetString(objv[i]); namespacePtr = Tcl_FindNamespace(interp, name, NULL, /* flags */ 0); if (namespacePtr) { @@ -3339,18 +3253,32 @@ NamespaceDeleteCmd( static int NamespaceEvalCmd( + ClientData clientData, /* Arbitrary value passed to cmd. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + return Tcl_NRCallObjProc(interp, NRNamespaceEvalCmd, clientData, objc, + objv); +} + +static int +NRNamespaceEvalCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { + Interp *iPtr = (Interp *) interp; + CmdFrame *invoker; + int word; Tcl_Namespace *namespacePtr; CallFrame *framePtr, **framePtrPtr; Tcl_Obj *objPtr; int result; - if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?"); + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "name arg ?arg...?"); return TCL_ERROR; } @@ -3359,19 +3287,16 @@ NamespaceEvalCmd( * namespace object along the way. */ - result = TclGetNamespaceFromObj(interp, objv[2], &namespacePtr); - if (result != TCL_OK) { - return result; - } + result = GetNamespaceFromObj(interp, objv[1], &namespacePtr); /* * If the namespace wasn't found, try to create it. */ - if (namespacePtr == NULL) { - char *name = TclGetString(objv[2]); - namespacePtr = Tcl_CreateNamespace(interp, name, (ClientData) NULL, - NULL); + if (result == TCL_ERROR) { + const char *name = TclGetString(objv[1]); + + namespacePtr = Tcl_CreateNamespace(interp, name, NULL, NULL); if (namespacePtr == NULL) { return TCL_ERROR; } @@ -3389,12 +3314,25 @@ NamespaceEvalCmd( if (result != TCL_OK) { return TCL_ERROR; } - framePtr->objc = objc; - framePtr->objv = objv; /* Reference counts do not need to be - * incremented here. */ - if (objc == 4) { - result = Tcl_EvalObjEx(interp, objv[3], 0); + if (iPtr->ensembleRewrite.sourceObjs == NULL) { + framePtr->objc = objc; + framePtr->objv = objv; + } else { + framePtr->objc = objc + iPtr->ensembleRewrite.numRemovedObjs + - iPtr->ensembleRewrite.numInsertedObjs; + framePtr->objv = iPtr->ensembleRewrite.sourceObjs; + } + + if (objc == 3) { + /* + * TIP #280: Make actual argument location available to eval'd script. + */ + + objPtr = objv[2]; + invoker = iPtr->cmdFramePtr; + word = 3; + TclArgumentGet(interp, objPtr, &invoker, &word); } else { /* * More than one argument: concatenate them together with spaces @@ -3402,19 +3340,39 @@ NamespaceEvalCmd( * object when it decrements its refcount after eval'ing it. */ - objPtr = Tcl_ConcatObj(objc-3, objv+3); - result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT); + objPtr = Tcl_ConcatObj(objc-2, objv+2); + invoker = NULL; + word = 0; } + /* + * TIP #280: Make invoking context available to eval'd script. + */ + + TclNRAddCallback(interp, NsEval_Callback, namespacePtr, "eval", + NULL, NULL); + return TclNREvalObjEx(interp, objPtr, 0, invoker, word); +} + +static int +NsEval_Callback( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_Namespace *namespacePtr = data[0]; + if (result == TCL_ERROR) { int length = strlen(namespacePtr->fullName); int limit = 200; int overflow = (length > limit); + char *cmd = data[1]; - TclFormatToErrorInfo(interp, - "\n (in namespace eval \"%.*s%s\" script line %d)", + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (in namespace %s \"%.*s%s\" script line %d)", + cmd, (overflow ? limit : length), namespacePtr->fullName, - (overflow ? "..." : ""), interp->errorLine); + (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); } /* @@ -3451,24 +3409,17 @@ NamespaceExistsCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Namespace *namespacePtr; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "name"); - return TCL_ERROR; - } - - /* - * Check whether the given namespace exists - */ - - if (TclGetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) { + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(namespacePtr != NULL)); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj( + GetNamespaceFromObj(interp, objv[1], &namespacePtr) == TCL_OK)); return TCL_OK; } @@ -3513,50 +3464,37 @@ NamespaceExportCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - Namespace *currNsPtr = (Namespace*) Tcl_GetCurrentNamespace(interp); - char *pattern, *string; - int resetListFirst = 0; - int firstArg, patternCt, i, result; + int firstArg, i; - if (objc < 2) { - Tcl_WrongNumArgs(interp, 2, objv, "?-clear? ?pattern pattern...?"); + if (objc < 1) { + Tcl_WrongNumArgs(interp, 1, objv, "?-clear? ?pattern pattern...?"); return TCL_ERROR; } /* - * Process the optional "-clear" argument. + * If no pattern arguments are given, and "-clear" isn't specified, return + * the namespace's current export pattern list. */ - firstArg = 2; - if (firstArg < objc) { - string = TclGetString(objv[firstArg]); - if (strcmp(string, "-clear") == 0) { - resetListFirst = 1; - firstArg++; - } + if (objc == 1) { + Tcl_Obj *listPtr = Tcl_NewObj(); + + (void) Tcl_AppendExportList(interp, NULL, listPtr); + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; } /* - * If no pattern arguments are given, and "-clear" isn't specified, return - * the namespace's current export pattern list. + * Process the optional "-clear" argument. */ - patternCt = (objc - firstArg); - if (patternCt == 0) { - if (firstArg > 2) { - return TCL_OK; - } else { /* create list with export patterns */ - Tcl_Obj *listPtr = Tcl_NewListObj(0, NULL); - result = Tcl_AppendExportList(interp, - (Tcl_Namespace *) currNsPtr, listPtr); - if (result != TCL_OK) { - return result; - } - Tcl_SetObjResult(interp, listPtr); - return TCL_OK; - } + firstArg = 1; + if (strcmp("-clear", Tcl_GetString(objv[firstArg])) == 0) { + Tcl_Export(interp, NULL, "::", 1); + Tcl_ResetResult(interp); + firstArg++; } /* @@ -3564,9 +3502,7 @@ NamespaceExportCmd( */ for (i = firstArg; i < objc; i++) { - pattern = TclGetString(objv[i]); - result = Tcl_Export(interp, (Tcl_Namespace *) currNsPtr, pattern, - ((i == firstArg)? resetListFirst : 0)); + int result = Tcl_Export(interp, NULL, Tcl_GetString(objv[i]), 0); if (result != TCL_OK) { return result; } @@ -3609,17 +3545,17 @@ NamespaceForgetCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - char *pattern; + const char *pattern; register int i, result; - if (objc < 2) { - Tcl_WrongNumArgs(interp, 2, objv, "?pattern pattern...?"); + if (objc < 1) { + Tcl_WrongNumArgs(interp, 1, objv, "?pattern pattern...?"); return TCL_ERROR; } - for (i = 2; i < objc; i++) { + for (i = 1; i < objc; i++) { pattern = TclGetString(objv[i]); result = Tcl_ForgetImport(interp, NULL, pattern); if (result != TCL_OK) { @@ -3654,6 +3590,10 @@ NamespaceForgetCmd( * treated as an error. But if the "-force" option is included, then * existing commands are overwritten by the imported commands. * + * If there are no pattern arguments and the "-force" flag isn't given, + * this command returns the list of commands currently imported in + * the current namespace. + * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * @@ -3670,15 +3610,15 @@ NamespaceImportCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { int allowOverwrite = 0; - char *string, *pattern; + const char *string, *pattern; register int i, result; int firstArg; - if (objc < 2) { - Tcl_WrongNumArgs(interp, 2, objv, "?-force? ?pattern pattern...?"); + if (objc < 1) { + Tcl_WrongNumArgs(interp, 1, objv, "?-force? ?pattern pattern...?"); return TCL_ERROR; } @@ -3686,13 +3626,36 @@ NamespaceImportCmd( * Skip over the optional "-force" as the first argument. */ - firstArg = 2; + firstArg = 1; if (firstArg < objc) { string = TclGetString(objv[firstArg]); if ((*string == '-') && (strcmp(string, "-force") == 0)) { allowOverwrite = 1; firstArg++; } + } else { + /* + * When objc == 1, command is just [namespace import]. Introspection + * form to return list of imported commands. + */ + + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp); + Tcl_Obj *listPtr; + + TclNewObj(listPtr); + for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + Command *cmdPtr = Tcl_GetHashValue(hPtr); + + if (cmdPtr->deleteProc == DeleteImportedCmd) { + Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewStringObj( + Tcl_GetHashKey(&nsPtr->cmdTable, hPtr) ,-1)); + } + } + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; } /* @@ -3748,17 +3711,30 @@ NamespaceImportCmd( static int NamespaceInscopeCmd( + ClientData clientData, /* Arbitrary value passed to cmd. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + return Tcl_NRCallObjProc(interp, NRNamespaceInscopeCmd, clientData, objc, + objv); +} + +static int +NRNamespaceInscopeCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Namespace *namespacePtr; - CallFrame *framePtr; + CallFrame *framePtr, **framePtrPtr; + register Interp *iPtr = (Interp *) interp; int i, result; + Tcl_Obj *cmdObjPtr; - if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?"); + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "name arg ?arg...?"); return TCL_ERROR; } @@ -3766,13 +3742,7 @@ NamespaceInscopeCmd( * Resolve the namespace reference. */ - result = TclGetNamespaceFromObj(interp, objv[2], &namespacePtr); - if (result != TCL_OK) { - return result; - } - if (namespacePtr == NULL) { - Tcl_AppendResult(interp, "unknown namespace \"", TclGetString(objv[2]), - "\" in inscope namespace command", NULL); + if (TclGetNamespaceFromObj(interp, objv[1], &namespacePtr) != TCL_OK) { return TCL_ERROR; } @@ -3780,13 +3750,22 @@ NamespaceInscopeCmd( * Make the specified namespace the current namespace. */ - result = TclPushStackFrame(interp, (Tcl_CallFrame **)&framePtr, + framePtrPtr = &framePtr; /* This is needed to satisfy GCC's + * strict aliasing rules. */ + result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, namespacePtr, /*isProcCallFrame*/ 0); if (result != TCL_OK) { return result; } - framePtr->objc = objc; - framePtr->objv = objv; + + if (iPtr->ensembleRewrite.sourceObjs == NULL) { + framePtr->objc = objc; + framePtr->objv = objv; + } else { + framePtr->objc = objc + iPtr->ensembleRewrite.numRemovedObjs + - iPtr->ensembleRewrite.numInsertedObjs; + framePtr->objv = iPtr->ensembleRewrite.sourceObjs; + } /* * Execute the command. If there is just one argument, just treat it as a @@ -3795,45 +3774,29 @@ NamespaceInscopeCmd( * of extra arguments to form the command to evaluate. */ - if (objc == 4) { - result = Tcl_EvalObjEx(interp, objv[3], 0); + if (objc == 3) { + cmdObjPtr = objv[2]; } else { Tcl_Obj *concatObjv[2]; - register Tcl_Obj *listPtr, *cmdObjPtr; + register Tcl_Obj *listPtr; listPtr = Tcl_NewListObj(0, NULL); - for (i = 4; i < objc; i++) { - result = Tcl_ListObjAppendElement(interp, listPtr, objv[i]); - if (result != TCL_OK) { - Tcl_DecrRefCount(listPtr); /* free unneeded obj */ - return result; + for (i = 3; i < objc; i++) { + if (Tcl_ListObjAppendElement(interp, listPtr, objv[i]) != TCL_OK){ + Tcl_DecrRefCount(listPtr); /* Free unneeded obj. */ + return TCL_ERROR; } } - concatObjv[0] = objv[3]; + concatObjv[0] = objv[2]; concatObjv[1] = listPtr; cmdObjPtr = Tcl_ConcatObj(2, concatObjv); - result = Tcl_EvalObjEx(interp, cmdObjPtr, TCL_EVAL_DIRECT); - Tcl_DecrRefCount(listPtr); /* we're done with the list object */ - } - - if (result == TCL_ERROR) { - int length = strlen(namespacePtr->fullName); - int limit = 200; - int overflow = (length > limit); - - TclFormatToErrorInfo(interp, - "\n (in namespace inscope \"%.*s%s\" script line %d)", - (overflow ? limit : length), namespacePtr->fullName, - (overflow ? "..." : ""), interp->errorLine); + Tcl_DecrRefCount(listPtr); /* We're done with the list object. */ } - /* - * Restore the previous "current" namespace. - */ - - TclPopStackFrame(interp); - return result; + TclNRAddCallback(interp, NsEval_Callback, namespacePtr, "inscope", + NULL, NULL); + return TclNREvalObjEx(interp, cmdObjPtr, 0, NULL, 0); } /* @@ -3870,25 +3833,27 @@ NamespaceOriginCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Command command, origCommand; Tcl_Obj *resultPtr; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "name"); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); return TCL_ERROR; } - command = Tcl_GetCommandFromObj(interp, objv[2]); - if (command == (Tcl_Command) NULL) { - Tcl_AppendResult(interp, "invalid command name \"", - TclGetString(objv[2]), "\"", NULL); + command = Tcl_GetCommandFromObj(interp, objv[1]); + if (command == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid command name \"%s\"", TclGetString(objv[1]))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", + TclGetString(objv[1]), NULL); return TCL_ERROR; } origCommand = TclGetOriginalCommand(command); - resultPtr = Tcl_NewObj(); - if (origCommand == (Tcl_Command) NULL) { + TclNewObj(resultPtr); + if (origCommand == NULL) { /* * The specified command isn't an imported command. Return the * command's name qualified by the full name of the namespace it was @@ -3929,26 +3894,18 @@ NamespaceParentCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Namespace *nsPtr; - int result; - if (objc == 2) { - nsPtr = Tcl_GetCurrentNamespace(interp); - } else if (objc == 3) { - result = TclGetNamespaceFromObj(interp, objv[2], &nsPtr); - if (result != TCL_OK) { - return result; - } - if (nsPtr == NULL) { - Tcl_AppendResult(interp, "unknown namespace \"", - TclGetString(objv[2]), - "\" in namespace parent command", NULL); + if (objc == 1) { + nsPtr = TclGetCurrentNamespace(interp); + } else if (objc == 2) { + if (TclGetNamespaceFromObj(interp, objv[1], &nsPtr) != TCL_OK) { return TCL_ERROR; } } else { - Tcl_WrongNumArgs(interp, 2, objv, "?name?"); + Tcl_WrongNumArgs(interp, 1, objv, "?name?"); return TCL_ERROR; } @@ -3995,16 +3952,15 @@ NamespacePathCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - Namespace *nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp); int i, nsObjc, result = TCL_ERROR; Tcl_Obj **nsObjv; Tcl_Namespace **namespaceList = NULL; - Tcl_Namespace *staticNs[4]; - if (objc > 3) { - Tcl_WrongNumArgs(interp, 2, objv, "?pathList?"); + if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?pathList?"); return TCL_ERROR; } @@ -4012,17 +3968,16 @@ NamespacePathCmd( * If no path is given, return the current path. */ - if (objc == 2) { - /* - * Not a very fast way to compute this, but easy to get right. - */ + if (objc == 1) { + Tcl_Obj *resultObj = Tcl_NewObj(); for (i=0 ; i<nsPtr->commandPathLength ; i++) { if (nsPtr->commandPathArray[i].nsPtr != NULL) { - Tcl_AppendElement(interp, - nsPtr->commandPathArray[i].nsPtr->fullName); + Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj( + nsPtr->commandPathArray[i].nsPtr->fullName, -1)); } } + Tcl_SetObjResult(interp, resultObj); return TCL_OK; } @@ -4030,27 +3985,18 @@ NamespacePathCmd( * There is a path given, so parse it into an array of namespace pointers. */ - if (Tcl_ListObjGetElements(interp, objv[2], &nsObjc, &nsObjv) != TCL_OK) { + if (TclListObjGetElements(interp, objv[1], &nsObjc, &nsObjv) != TCL_OK) { goto badNamespace; } if (nsObjc != 0) { - if (nsObjc > 4) { - namespaceList = (Tcl_Namespace **) - ckalloc(sizeof(Tcl_Namespace *) * nsObjc); - } else { - namespaceList = staticNs; - } + namespaceList = TclStackAlloc(interp, + sizeof(Tcl_Namespace *) * nsObjc); for (i=0 ; i<nsObjc ; i++) { if (TclGetNamespaceFromObj(interp, nsObjv[i], &namespaceList[i]) != TCL_OK) { goto badNamespace; } - if (namespaceList[i] == NULL) { - Tcl_AppendResult(interp, "unknown namespace \"", - TclGetString(nsObjv[i]), "\"", NULL); - goto badNamespace; - } } } @@ -4058,12 +4004,12 @@ NamespacePathCmd( * Now we have the list of valid namespaces, install it as the path. */ - SetNsPath(nsPtr, nsObjc, namespaceList); + TclSetNsPath(nsPtr, nsObjc, namespaceList); result = TCL_OK; badNamespace: - if (namespaceList != NULL && namespaceList != staticNs) { - ckfree((char *) namespaceList); + if (namespaceList != NULL) { + TclStackFree(interp, namespaceList); } return result; } @@ -4071,7 +4017,7 @@ NamespacePathCmd( /* *---------------------------------------------------------------------- * - * SetNsPath -- + * TclSetNsPath -- * * Sets the namespace command name resolution path to the given list of * namespaces. If the list is empty (of zero length) the path is set to @@ -4088,19 +4034,17 @@ NamespacePathCmd( *---------------------------------------------------------------------- */ -/* EXPOSE ME? */ -static void -SetNsPath( +void +TclSetNsPath( Namespace *nsPtr, /* Namespace whose path is to be set. */ - int pathLength, /* Length of pathAry */ + int pathLength, /* Length of pathAry. */ Tcl_Namespace *pathAry[]) /* Array of namespaces that are the path. */ { - NamespacePathEntry *tmpPathArray; - int i; - if (pathLength != 0) { - tmpPathArray = (NamespacePathEntry *) + NamespacePathEntry *tmpPathArray = ckalloc(sizeof(NamespacePathEntry) * pathLength); + int i; + for (i=0 ; i<pathLength ; i++) { tmpPathArray[i].nsPtr = (Namespace *) pathAry[i]; tmpPathArray[i].creatorNsPtr = nsPtr; @@ -4153,6 +4097,7 @@ UnlinkNsPath( int i; for (i=0 ; i<nsPtr->commandPathLength ; i++) { NamespacePathEntry *nsPathPtr = &nsPtr->commandPathArray[i]; + if (nsPathPtr->prevPtr != NULL) { nsPathPtr->prevPtr->nextPtr = nsPathPtr->nextPtr; } @@ -4165,7 +4110,7 @@ UnlinkNsPath( } } } - ckfree((char *) nsPtr->commandPathArray); + ckfree(nsPtr->commandPathArray); } /* @@ -4193,6 +4138,7 @@ TclInvalidateNsPath( Namespace *nsPtr) { NamespacePathEntry *nsPathPtr = nsPtr->commandPathSourceList; + while (nsPathPtr != NULL) { if (nsPathPtr->nsPtr != NULL) { nsPathPtr->creatorNsPtr->cmdRefEpoch++; @@ -4231,13 +4177,13 @@ NamespaceQualifiersCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - register char *name, *p; + register const char *name, *p; int length; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "string"); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "string"); return TCL_ERROR; } @@ -4246,15 +4192,15 @@ NamespaceQualifiersCmd( * the last "::" qualifier. */ - name = TclGetString(objv[2]); + name = TclGetString(objv[1]); for (p = name; *p != '\0'; p++) { /* empty body */ } while (--p >= name) { if ((*p == ':') && (p > name) && (*(p-1) == ':')) { - p -= 2; /* back up over the :: */ + p -= 2; /* Back up over the :: */ while ((p >= name) && (*p == ':')) { - p--; /* back up over the preceeding : */ + p--; /* Back up over the preceeding : */ } break; } @@ -4270,61 +4216,64 @@ NamespaceQualifiersCmd( /* *---------------------------------------------------------------------- * - * NamespaceTailCmd -- + * NamespaceUnknownCmd -- * - * Invoked to implement the "namespace tail" command that returns the - * trailing name at the end of a string with "::" namespace qualifiers. - * These qualifiers are namespace names separated by "::"s. For example, - * for "::foo::p" this command returns "p", and for "::" it returns "". - * This command is the complement of the "namespace qualifiers" command. - * Note that this command does not check whether the "namespace" names - * are, in fact, the names of currently defined namespaces. Handles the - * following syntax: + * Invoked to implement the "namespace unknown" command (TIP 181) that + * sets or queries a per-namespace unknown command handler. This handler + * is called when command lookup fails (current and global ns). The + * default handler for the global namespace is ::unknown. The default + * handler for other namespaces is to call the global namespace unknown + * handler. Passing an empty list results in resetting the handler to its + * default. * - * namespace tail string + * namespace unknown ?handler? * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: - * Returns a result in the interpreter's result object. If anything goes + * If no handler is specified, returns a result in the interpreter's + * result object, otherwise it sets the unknown handler pointer in the + * current namespace to the script fragment provided. If anything goes * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int -NamespaceTailCmd( +NamespaceUnknownCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - register char *name, *p; + Tcl_Namespace *currNsPtr; + Tcl_Obj *resultPtr; + int rc; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "string"); + if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?script?"); return TCL_ERROR; } - /* - * Find the end of the string, then work backward and find the last "::" - * qualifier. - */ + currNsPtr = TclGetCurrentNamespace(interp); - name = TclGetString(objv[2]); - for (p = name; *p != '\0'; p++) { - /* empty body */ - } - while (--p > name) { - if ((*p == ':') && (*(p-1) == ':')) { - p++; /* just after the last "::" */ - break; - } - } + if (objc == 1) { + /* + * Introspection - return the current namespace handler. + */ - if (p >= name) { - Tcl_SetObjResult(interp, Tcl_NewStringObj(p, -1)); + resultPtr = Tcl_GetNamespaceUnknownHandler(interp, currNsPtr); + if (resultPtr == NULL) { + TclNewObj(resultPtr); + } + Tcl_SetObjResult(interp, resultPtr); + } else { + rc = Tcl_SetNamespaceUnknownHandler(interp, currNsPtr, objv[1]); + if (rc == TCL_OK) { + Tcl_SetObjResult(interp, objv[1]); + } + return rc; } return TCL_OK; } @@ -4332,2305 +4281,760 @@ NamespaceTailCmd( /* *---------------------------------------------------------------------- * - * NamespaceWhichCmd -- + * Tcl_GetNamespaceUnknownHandler -- * - * Invoked to implement the "namespace which" command that returns the - * fully-qualified name of a command or variable. If the specified - * command or variable does not exist, it returns "". Handles the - * following syntax: - * - * namespace which ?-command? ?-variable? name + * Returns the unknown command handler registered for the given + * namespace. * * Results: - * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. + * Returns the current unknown command handler, or NULL if none exists + * for the namespace. * * Side effects: - * Returns a result in the interpreter's result object. If anything goes - * wrong, the result is an error message. + * None. * *---------------------------------------------------------------------- */ -static int -NamespaceWhichCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ +Tcl_Obj * +Tcl_GetNamespaceUnknownHandler( + Tcl_Interp *interp, /* The interpreter in which the namespace + * exists. */ + Tcl_Namespace *nsPtr) /* The namespace. */ { - static CONST char *opts[] = { - "-command", "-variable", NULL - }; - int lookupType = 0; - Tcl_Obj *resultPtr; + Namespace *currNsPtr = (Namespace *) nsPtr; - if (objc < 3 || objc > 4) { - badArgs: - Tcl_WrongNumArgs(interp, 2, objv, "?-command? ?-variable? name"); - return TCL_ERROR; - } else if (objc == 4) { + if (currNsPtr->unknownHandlerPtr == NULL && + currNsPtr == ((Interp *) interp)->globalNsPtr) { /* - * Look for a flag controlling the lookup. + * Default handler for global namespace is "::unknown". For all other + * namespaces, it is NULL (which falls back on the global unknown + * handler). */ - if (Tcl_GetIndexFromObj(interp, objv[2], opts, "option", 0, - &lookupType) != TCL_OK) { - /* - * Preserve old style of error message! - */ - - Tcl_ResetResult(interp); - goto badArgs; - } - } - - resultPtr = Tcl_NewObj(); - switch (lookupType) { - case 0: { /* -command */ - Tcl_Command cmd = Tcl_GetCommandFromObj(interp, objv[objc-1]); - - if (cmd != (Tcl_Command) NULL) { - Tcl_GetCommandFullName(interp, cmd, resultPtr); - } - break; + TclNewLiteralStringObj(currNsPtr->unknownHandlerPtr, "::unknown"); + Tcl_IncrRefCount(currNsPtr->unknownHandlerPtr); } - case 1: { /* -variable */ - Tcl_Var var = Tcl_FindNamespaceVar(interp, - TclGetString(objv[objc-1]), NULL, /*flags*/ 0); - - if (var != (Tcl_Var) NULL) { - Tcl_GetVariableFullName(interp, var, resultPtr); - } - break; - } - } - Tcl_SetObjResult(interp, resultPtr); - return TCL_OK; + return currNsPtr->unknownHandlerPtr; } /* *---------------------------------------------------------------------- * - * FreeNsNameInternalRep -- + * Tcl_SetNamespaceUnknownHandler -- * - * Frees the resources associated with a nsName object's internal - * representation. + * Sets the unknown command handler for the given namespace to the + * command prefix passed. * * Results: - * None. + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: - * Decrements the ref count of any Namespace structure pointed to by the - * nsName's internal representation. If there are no more references to - * the namespace, it's structure will be freed. + * Sets the namespace unknown command handler. If the passed in handler + * is NULL or an empty list, then the handler is reset to its default. If + * an error occurs, then an error message is left in the interpreter + * result. * *---------------------------------------------------------------------- */ -static void -FreeNsNameInternalRep( - register Tcl_Obj *objPtr) /* nsName object with internal representation - * to free */ +int +Tcl_SetNamespaceUnknownHandler( + Tcl_Interp *interp, /* Interpreter in which the namespace + * exists. */ + Tcl_Namespace *nsPtr, /* Namespace which is being updated. */ + Tcl_Obj *handlerPtr) /* The new handler, or NULL to reset. */ { - register ResolvedNsName *resNamePtr = (ResolvedNsName *) - objPtr->internalRep.otherValuePtr; - Namespace *nsPtr; + int lstlen = 0; + Namespace *currNsPtr = (Namespace *) nsPtr; /* - * Decrement the reference count of the namespace. If there are no more - * references, free it up. + * Ensure that we check for errors *first* before we change anything. */ - if (resNamePtr != NULL) { - resNamePtr->refCount--; - if (resNamePtr->refCount == 0) { - + if (handlerPtr != NULL) { + if (TclListObjLength(interp, handlerPtr, &lstlen) != TCL_OK) { /* - * Decrement the reference count for the cached namespace. If the - * namespace is dead, and there are no more references to it, free - * it. + * Not a list. */ - nsPtr = resNamePtr->nsPtr; - nsPtr->refCount--; - if ((nsPtr->refCount == 0) && (nsPtr->flags & NS_DEAD)) { - NamespaceFree(nsPtr); - } - ckfree((char *) resNamePtr); + return TCL_ERROR; } - } -} - -/* - *---------------------------------------------------------------------- - * - * DupNsNameInternalRep -- - * - * Initializes the internal representation of a nsName object to a copy - * of the internal representation of another nsName object. - * - * Results: - * None. - * - * Side effects: - * copyPtr's internal rep is set to refer to the same namespace - * referenced by srcPtr's internal rep. Increments the ref count of the - * ResolvedNsName structure used to hold the namespace reference. - * - *---------------------------------------------------------------------- - */ - -static void -DupNsNameInternalRep( - Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ - register Tcl_Obj *copyPtr) /* Object with internal rep to set. */ -{ - register ResolvedNsName *resNamePtr = (ResolvedNsName *) - srcPtr->internalRep.otherValuePtr; + if (lstlen > 0) { + /* + * We are going to be saving this handler. Increment the reference + * count before decrementing the refcount on the previous handler, + * so that nothing strange can happen if we are told to set the + * handler to the previous value. + */ - copyPtr->internalRep.otherValuePtr = (void *) resNamePtr; - if (resNamePtr != NULL) { - resNamePtr->refCount++; + Tcl_IncrRefCount(handlerPtr); + } } - copyPtr->typePtr = &tclNsNameType; -} - -/* - *---------------------------------------------------------------------- - * - * SetNsNameFromAny -- - * - * Attempt to generate a nsName internal representation for a Tcl object. - * - * Results: - * Returns TCL_OK if the value could be converted to a proper namespace - * reference. Otherwise, it returns TCL_ERROR, along with an error - * message in the interpreter's result object. - * - * Side effects: - * If successful, the object is made a nsName object. Its internal rep is - * set to point to a ResolvedNsName, which contains a cached pointer to - * the Namespace. Reference counts are kept on both the ResolvedNsName - * and the Namespace, so we can keep track of their usage and free them - * when appropriate. - * - *---------------------------------------------------------------------- - */ - -static int -SetNsNameFromAny( - Tcl_Interp *interp, /* Points to the namespace in which to resolve - * name. Also used for error reporting if not - * NULL. */ - register Tcl_Obj *objPtr) /* The object to convert. */ -{ - char *name; - CONST char *dummy; - Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr; - register ResolvedNsName *resNamePtr; /* - * Get the string representation. Make it up-to-date if necessary. + * Remove old handler next. */ - name = objPtr->bytes; - if (name == NULL) { - name = TclGetString(objPtr); + if (currNsPtr->unknownHandlerPtr != NULL) { + Tcl_DecrRefCount(currNsPtr->unknownHandlerPtr); } /* - * Look for the namespace "name" in the current namespace. If there is an - * error parsing the (possibly qualified) name, return an error. If the - * namespace isn't found, we convert the object to an nsName object with a - * NULL ResolvedNsName* internal rep. + * Install the new handler. */ - TclGetNamespaceForQualName(interp, name, NULL, TCL_FIND_ONLY_NS, - &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); - - /* - * If we found a namespace, then create a new ResolvedNsName structure - * that holds a reference to it. - */ + if (lstlen > 0) { + /* + * Just store the handler. It already has the correct reference count. + */ - if (nsPtr != NULL) { - Namespace *currNsPtr = (Namespace *) - Tcl_GetCurrentNamespace(interp); - - nsPtr->refCount++; - resNamePtr = (ResolvedNsName *) ckalloc(sizeof(ResolvedNsName)); - resNamePtr->nsPtr = nsPtr; - resNamePtr->nsId = nsPtr->nsId; - resNamePtr->refNsPtr = currNsPtr; - resNamePtr->refCount = 1; + currNsPtr->unknownHandlerPtr = handlerPtr; } else { - resNamePtr = NULL; - } - - /* - * Free the old internalRep before setting the new one. We do this as late - * as possible to allow the conversion code (in particular, - * Tcl_GetStringFromObj) to use that old internalRep. - */ + /* + * If NULL or an empty list is passed, this resets to the default + * handler. + */ - TclFreeIntRep(objPtr); - objPtr->internalRep.otherValuePtr = (void *) resNamePtr; - objPtr->typePtr = &tclNsNameType; + currNsPtr->unknownHandlerPtr = NULL; + } return TCL_OK; } /* *---------------------------------------------------------------------- * - * UpdateStringOfNsName -- + * NamespaceTailCmd -- * - * Updates the string representation for a nsName object. Note: This - * function does not free an existing old string rep so storage will be - * lost if this has not already been done. + * Invoked to implement the "namespace tail" command that returns the + * trailing name at the end of a string with "::" namespace qualifiers. + * These qualifiers are namespace names separated by "::"s. For example, + * for "::foo::p" this command returns "p", and for "::" it returns "". + * This command is the complement of the "namespace qualifiers" command. + * Note that this command does not check whether the "namespace" names + * are, in fact, the names of currently defined namespaces. Handles the + * following syntax: + * + * namespace tail string * * Results: - * None. + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: - * The object's string is set to a copy of the fully qualified namespace - * name. + * Returns a result in the interpreter's result object. If anything goes + * wrong, the result is an error message. * *---------------------------------------------------------------------- */ -static void -UpdateStringOfNsName( - register Tcl_Obj *objPtr) /* nsName object with string rep to update. */ +static int +NamespaceTailCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - ResolvedNsName *resNamePtr = - (ResolvedNsName *) objPtr->internalRep.otherValuePtr; - register Namespace *nsPtr; - char *name = ""; - int length; + register const char *name, *p; - if ((resNamePtr != NULL) - && (resNamePtr->nsId == resNamePtr->nsPtr->nsId)) { - nsPtr = resNamePtr->nsPtr; - if (nsPtr->flags & NS_DEAD) { - nsPtr = NULL; - } - if (nsPtr != NULL) { - name = nsPtr->fullName; - } + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "string"); + return TCL_ERROR; } /* - * The following sets the string rep to an empty string on the heap if the - * internal rep is NULL. + * Find the end of the string, then work backward and find the last "::" + * qualifier. */ - length = strlen(name); - if (length == 0) { - objPtr->bytes = tclEmptyStringRep; - } else { - objPtr->bytes = (char *) ckalloc((unsigned) (length + 1)); - memcpy((void *) objPtr->bytes, (void *) name, (unsigned) length); - objPtr->bytes[length] = '\0'; + name = TclGetString(objv[1]); + for (p = name; *p != '\0'; p++) { + /* empty body */ + } + while (--p > name) { + if ((*p == ':') && (*(p-1) == ':')) { + p++; /* Just after the last "::" */ + break; + } + } + + if (p >= name) { + Tcl_SetObjResult(interp, Tcl_NewStringObj(p, -1)); } - objPtr->length = length; + return TCL_OK; } /* *---------------------------------------------------------------------- * - * NamespaceEnsembleCmd -- + * NamespaceUpvarCmd -- * - * Invoked to implement the "namespace ensemble" command that creates and - * manipulates ensembles built on top of namespaces. Handles the - * following syntax: + * Invoked to implement the "namespace upvar" command, that creates + * variables in the current scope linked to variables in another + * namespace. Handles the following syntax: * - * namespace ensemble name ?dictionary? + * namespace upvar ns otherVar myVar ?otherVar myVar ...? * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: - * Creates the ensemble for the namespace if one did not previously - * exist. Alternatively, alters the way that the ensemble's subcommand => - * implementation prefix is configured. + * Creates new variables in the current scope, linked to the + * corresponding variables in the stipulated nmamespace. If anything goes + * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int -NamespaceEnsembleCmd( - ClientData dummy, - Tcl_Interp *interp, - int objc, - Tcl_Obj *CONST objv[]) +NamespaceUpvarCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - Namespace *nsPtr; - Tcl_Command token; - static CONST char *subcommands[] = { - "configure", "create", "exists", NULL - }; - enum EnsSubcmds { - ENS_CONFIG, ENS_CREATE, ENS_EXISTS - }; - static CONST char *createOptions[] = { - "-command", "-map", "-prefixes", "-subcommands", "-unknown", NULL - }; - enum EnsCreateOpts { - CRT_CMD, CRT_MAP, CRT_PREFIX, CRT_SUBCMDS, CRT_UNKNOWN - }; - static CONST char *configOptions[] = { - "-map", "-namespace", "-prefixes", "-subcommands", "-unknown", NULL - }; - enum EnsConfigOpts { - CONF_MAP, CONF_NAMESPACE, CONF_PREFIX, CONF_SUBCMDS, CONF_UNKNOWN - }; - int index; + Interp *iPtr = (Interp *) interp; + Tcl_Namespace *nsPtr, *savedNsPtr; + Var *otherPtr, *arrayPtr; + const char *myName; - nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); - if (nsPtr == NULL || nsPtr->flags & NS_DEAD) { - if (!Tcl_InterpDeleted(interp)) { - Tcl_AppendResult(interp, - "tried to manipulate ensemble of deleted namespace", NULL); - } + if (objc < 2 || (objc & 1)) { + Tcl_WrongNumArgs(interp, 1, objv, "ns ?otherVar myVar ...?"); return TCL_ERROR; } - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "subcommand ?arg ...?"); + if (TclGetNamespaceFromObj(interp, objv[1], &nsPtr) != TCL_OK) { return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[2], subcommands, "subcommand", 0, - &index) != TCL_OK) { - return TCL_ERROR; - } - - switch ((enum EnsSubcmds) index) { - case ENS_CREATE: { - char *name; - Tcl_DictSearch search; - Tcl_Obj *listObj; - int done, len, allocatedMapFlag = 0; - /* - * Defaults - */ - Tcl_Obj *subcmdObj = NULL; - Tcl_Obj *mapObj = NULL; - int permitPrefix = 1; - Tcl_Obj *unknownObj = NULL; - - objv += 3; - objc -= 3; - /* - * Work out what name to use for the command to create. If supplied, - * it is either fully specified or relative to the current namespace. - * If not supplied, it is exactly the name of the current namespace. - */ - - name = nsPtr->fullName; + objc -= 2; + objv += 2; + for (; objc>0 ; objc-=2, objv+=2) { /* - * 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. + * Locate the other variable. */ - for (; objc>1 ; objc-=2,objv+=2 ) { - if (Tcl_GetIndexFromObj(interp, objv[0], createOptions, "option", - 0, &index) != TCL_OK) { - if (allocatedMapFlag) { - Tcl_DecrRefCount(mapObj); - } - return TCL_ERROR; - } - switch ((enum EnsCreateOpts) index) { - case CRT_CMD: - name = TclGetString(objv[1]); - continue; - case CRT_SUBCMDS: - if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) { - if (allocatedMapFlag) { - Tcl_DecrRefCount(mapObj); - } - return TCL_ERROR; - } - subcmdObj = (len > 0 ? objv[1] : NULL); - continue; - case CRT_MAP: { - Tcl_Obj *patchedDict = NULL, *subcmdObj; - - /* - * Verify that the map is sensible. - */ - - if (Tcl_DictObjFirst(interp, objv[1], &search, - &subcmdObj, &listObj, &done) != TCL_OK) { - if (allocatedMapFlag) { - Tcl_DecrRefCount(mapObj); - } - return TCL_ERROR; - } - if (done) { - mapObj = NULL; - continue; - } - do { - Tcl_Obj **listv; - char *cmd; - - if (Tcl_ListObjGetElements(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_SetResult(interp, - "ensemble subcommand implementations " - "must be non-empty lists", TCL_STATIC); - 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 = Tcl_NewStringObj(nsPtr->fullName,-1); - - if (nsPtr->parentPtr) { - Tcl_AppendStringsToObj(newCmd, "::", NULL); - } - Tcl_AppendObjToObj(newCmd, listv[0]); - Tcl_ListObjReplace(NULL, newList, 0, 1, 1, &newCmd); - if (patchedDict == NULL) { - patchedDict = Tcl_DuplicateObj(objv[1]); - } - Tcl_DictObjPut(NULL, patchedDict, subcmdObj, newList); - } - Tcl_DictObjNext(&search, &subcmdObj, &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 (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) { - if (allocatedMapFlag) { - Tcl_DecrRefCount(mapObj); - } - return TCL_ERROR; - } - unknownObj = (len > 0 ? objv[1] : NULL); - continue; - } + savedNsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; + iPtr->varFramePtr->nsPtr = (Namespace *) nsPtr; + otherPtr = TclObjLookupVarEx(interp, objv[0], NULL, + (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access", + /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); + iPtr->varFramePtr->nsPtr = (Namespace *) savedNsPtr; + if (otherPtr == NULL) { + return TCL_ERROR; } /* - * 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.) + * Create the new variable and link it to otherPtr. */ - token = Tcl_CreateEnsemble(interp, name, NULL, - (permitPrefix ? TCL_ENSEMBLE_PREFIX : 0)); - Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj); - Tcl_SetEnsembleMappingDict(interp, token, mapObj); - Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj); - - /* - * Tricky! Must ensure that the result is not shared (command delete - * traces could have corrupted the pristine object that we started - * with). [Snit test rename-1.5] - */ - - Tcl_ResetResult(interp); - Tcl_GetCommandFullName(interp, token, Tcl_GetObjResult(interp)); - return TCL_OK; - } - - case ENS_EXISTS: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 3, objv, "cmdname"); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj( - Tcl_FindEnsemble(interp, objv[3], 0) != NULL)); - return TCL_OK; - - case ENS_CONFIG: - if (objc < 4 || (objc != 5 && objc & 1)) { - Tcl_WrongNumArgs(interp, 3, objv, "cmdname ?opt? ?value? ..."); - return TCL_ERROR; - } - token = Tcl_FindEnsemble(interp, objv[3], TCL_LEAVE_ERR_MSG); - if (token == NULL) { + myName = TclGetString(objv[1]); + if (TclPtrMakeUpvar(interp, otherPtr, myName, 0, -1) != TCL_OK) { return TCL_ERROR; } - - if (objc == 5) { - Tcl_Obj *resultObj = NULL; /* silence gcc 4 warning */ - - if (Tcl_GetIndexFromObj(interp, objv[4], configOptions, "option", - 0, &index) != TCL_OK) { - return TCL_ERROR; - } - switch ((enum EnsConfigOpts) index) { - case CONF_SUBCMDS: - Tcl_GetEnsembleSubcommandList(NULL, token, &resultObj); - if (resultObj != NULL) { - Tcl_SetObjResult(interp, resultObj); - } - break; - case CONF_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_SetResult(interp, ((Namespace *)namespacePtr)->fullName, - TCL_VOLATILE); - 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; - - } else if (objc == 4) { - /* - * Produce list of all information. - */ - - Tcl_Obj *resultObj, *tmpObj = NULL; /* silence gcc 4 warning */ - Tcl_Namespace *namespacePtr = NULL; /* silence gcc 4 warning */ - int flags = 0; /* silence gcc 4 warning */ - - TclNewObj(resultObj); - - /* -map option */ - Tcl_ListObjAppendElement(NULL, resultObj, - Tcl_NewStringObj(configOptions[CONF_MAP], -1)); - Tcl_GetEnsembleMappingDict(NULL, token, &tmpObj); - if (tmpObj != NULL) { - Tcl_ListObjAppendElement(NULL, resultObj, tmpObj); - } else { - Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewObj()); - } - - /* -namespace option */ - Tcl_ListObjAppendElement(NULL, resultObj, - Tcl_NewStringObj(configOptions[CONF_NAMESPACE], -1)); - Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr); - Tcl_ListObjAppendElement(NULL, resultObj, - Tcl_NewStringObj(((Namespace *)namespacePtr)->fullName, - -1)); - - /* -prefix option */ - Tcl_ListObjAppendElement(NULL, resultObj, - Tcl_NewStringObj(configOptions[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(configOptions[CONF_SUBCMDS], -1)); - Tcl_GetEnsembleSubcommandList(NULL, token, &tmpObj); - if (tmpObj != NULL) { - Tcl_ListObjAppendElement(NULL, resultObj, tmpObj); - } else { - Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewObj()); - } - - /* -unknown option */ - Tcl_ListObjAppendElement(NULL, resultObj, - Tcl_NewStringObj(configOptions[CONF_UNKNOWN], -1)); - Tcl_GetEnsembleUnknownHandler(NULL, token, &tmpObj); - if (tmpObj != NULL) { - Tcl_ListObjAppendElement(NULL, resultObj, tmpObj); - } else { - Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewObj()); - } - - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; - } else { - Tcl_DictSearch search; - Tcl_Obj *listObj; - int done, len, allocatedMapFlag = 0; - Tcl_Obj *subcmdObj = NULL, *mapObj = 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_GetEnsembleUnknownHandler(NULL, token, &unknownObj); - Tcl_GetEnsembleFlags(NULL, token, &flags); - permitPrefix = (flags & TCL_ENSEMBLE_PREFIX) != 0; - - objv += 4; - objc -= 4; - - /* - * 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], configOptions, - "option", 0, &index) != TCL_OK) { - if (allocatedMapFlag) { - Tcl_DecrRefCount(mapObj); - } - return TCL_ERROR; - } - switch ((enum EnsConfigOpts) index) { - case CONF_SUBCMDS: - if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) { - if (allocatedMapFlag) { - Tcl_DecrRefCount(mapObj); - } - return TCL_ERROR; - } - subcmdObj = (len > 0 ? objv[1] : NULL); - continue; - case CONF_MAP: { - Tcl_Obj *patchedDict = NULL, *subcmdObj; - - /* - * Verify that the map is sensible. - */ - - if (Tcl_DictObjFirst(interp, objv[1], &search, - &subcmdObj, &listObj, &done) != TCL_OK) { - if (allocatedMapFlag) { - Tcl_DecrRefCount(mapObj); - } - return TCL_ERROR; - } - if (done) { - mapObj = NULL; - continue; - } - do { - Tcl_Obj **listv; - char *cmd; - - if (Tcl_ListObjGetElements(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_SetResult(interp, - "ensemble subcommand implementations " - "must be non-empty lists", TCL_STATIC); - 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 = - Tcl_NewStringObj(nsPtr->fullName, -1); - if (nsPtr->parentPtr) { - Tcl_AppendStringsToObj(newCmd, "::", NULL); - } - Tcl_AppendObjToObj(newCmd, listv[0]); - Tcl_ListObjReplace(NULL, newList, 0,1, 1,&newCmd); - if (patchedDict == NULL) { - patchedDict = Tcl_DuplicateObj(objv[1]); - } - Tcl_DictObjPut(NULL, patchedDict, subcmdObj, - newList); - } - Tcl_DictObjNext(&search, &subcmdObj, &listObj, &done); - } while (!done); - if (allocatedMapFlag) { - Tcl_DecrRefCount(mapObj); - } - mapObj = (patchedDict ? patchedDict : objv[1]); - if (patchedDict) { - allocatedMapFlag = 1; - } - continue; - } - case CONF_NAMESPACE: - if (allocatedMapFlag) { - Tcl_DecrRefCount(mapObj); - } - Tcl_AppendResult(interp, "option -namespace is read-only", - NULL); - return TCL_ERROR; - case CONF_PREFIX: - if (Tcl_GetBooleanFromObj(interp, objv[1], - &permitPrefix) != TCL_OK) { - if (allocatedMapFlag) { - Tcl_DecrRefCount(mapObj); - } - return TCL_ERROR; - } - continue; - case CONF_UNKNOWN: - if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) { - if (allocatedMapFlag) { - Tcl_DecrRefCount(mapObj); - } - return TCL_ERROR; - } - unknownObj = (len > 0 ? objv[1] : NULL); - continue; - } - } - - /* - * Update the namespace now that we've finished the parsing stage. - */ - - flags = (permitPrefix ? flags|TCL_ENSEMBLE_PREFIX - : flags&~TCL_ENSEMBLE_PREFIX); - Tcl_SetEnsembleSubcommandList(NULL, token, subcmdObj); - Tcl_SetEnsembleMappingDict(NULL, token, mapObj); - Tcl_SetEnsembleUnknownHandler(NULL, token, unknownObj); - Tcl_SetEnsembleFlags(NULL, token, flags); - return TCL_OK; - } - - default: - Tcl_Panic("unexpected ensemble command"); } + return TCL_OK; } /* *---------------------------------------------------------------------- * - * Tcl_CreateEnsemble -- - * - * Create a simple ensemble attached to the given namespace. - * - * Results: - * The token for the command created. - * - * Side effects: - * The ensemble is created and marked for compilation. - * - *---------------------------------------------------------------------- - */ - -Tcl_Command -Tcl_CreateEnsemble( - Tcl_Interp *interp, - CONST char *name, - Tcl_Namespace *namespacePtr, - int flags) -{ - Namespace *nsPtr = (Namespace *) namespacePtr; - EnsembleConfig *ensemblePtr = - (EnsembleConfig *) ckalloc(sizeof(EnsembleConfig)); - Tcl_Obj *nameObj = NULL; - - if (nsPtr == NULL) { - nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); - } - - /* - * Make the name of the ensemble into a fully qualified name. This might - * allocate a temporary object. - */ - - if (!(name[0] == ':' && name[1] == ':')) { - nameObj = Tcl_NewStringObj(nsPtr->fullName, -1); - if (nsPtr->parentPtr == NULL) { - Tcl_AppendStringsToObj(nameObj, name, NULL); - } else { - Tcl_AppendStringsToObj(nameObj, "::", name, NULL); - } - Tcl_IncrRefCount(nameObj); - name = TclGetString(nameObj); - } - - ensemblePtr->nsPtr = nsPtr; - ensemblePtr->epoch = 0; - Tcl_InitHashTable(&ensemblePtr->subcommandTable, TCL_STRING_KEYS); - ensemblePtr->subcommandArrayPtr = NULL; - ensemblePtr->subcmdList = NULL; - ensemblePtr->subcommandDict = NULL; - ensemblePtr->flags = flags; - ensemblePtr->unknownHandler = NULL; - ensemblePtr->token = Tcl_CreateObjCommand(interp, name, - NsEnsembleImplementationCmd, (ClientData)ensemblePtr, - DeleteEnsembleConfig); - ensemblePtr->next = (EnsembleConfig *) nsPtr->ensembles; - nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr; - - /* - * Trigger an eventual recomputation of the ensemble command set. Note - * that this is slightly tricky, as it means that we are not actually - * counting the number of namespace export actions, but it is the simplest - * way to go! - */ - - nsPtr->exportLookupEpoch++; - - if (nameObj != NULL) { - TclDecrRefCount(nameObj); - } - return ensemblePtr->token; -} - -/* - *---------------------------------------------------------------------- + * NamespaceWhichCmd -- * - * Tcl_SetEnsembleSubcommandList -- + * Invoked to implement the "namespace which" command that returns the + * fully-qualified name of a command or variable. If the specified + * command or variable does not exist, it returns "". Handles the + * following syntax: * - * Set the subcommand list for a particular ensemble. + * namespace which ?-command? ?-variable? name * * Results: - * Tcl result code (error if command token does not indicate an ensemble - * or the subcommand list - if non-NULL - is not a list). + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: - * The ensemble is updated and marked for recompilation. + * Returns a result in the interpreter's result object. If anything goes + * wrong, the result is an error message. * *---------------------------------------------------------------------- */ -int -Tcl_SetEnsembleSubcommandList( - Tcl_Interp *interp, - Tcl_Command token, - Tcl_Obj *subcmdList) +static int +NamespaceWhichCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - Command *cmdPtr = (Command *) token; - EnsembleConfig *ensemblePtr; - Tcl_Obj *oldList; + static const char *const opts[] = { + "-command", "-variable", NULL + }; + int lookupType = 0; + Tcl_Obj *resultPtr; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { - if (interp != NULL) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); - } + if (objc < 2 || objc > 3) { + badArgs: + Tcl_WrongNumArgs(interp, 1, objv, "?-command? ?-variable? name"); return TCL_ERROR; - } - if (subcmdList != NULL) { - int length; - if (Tcl_ListObjLength(interp, subcmdList, &length) != TCL_OK) { - return TCL_ERROR; - } - if (length < 1) { - subcmdList = NULL; - } - } - - ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData; - oldList = ensemblePtr->subcmdList; - ensemblePtr->subcmdList = subcmdList; - if (subcmdList != NULL) { - Tcl_IncrRefCount(subcmdList); - } - if (oldList != NULL) { - TclDecrRefCount(oldList); - } - - /* - * Trigger an eventual recomputation of the ensemble command set. Note - * that this is slightly tricky, as it means that we are not actually - * counting the number of namespace export actions, but it is the simplest - * way to go! - */ - - ensemblePtr->nsPtr->exportLookupEpoch++; - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetEnsembleMappingDict -- - * - * Set the mapping dictionary for a particular ensemble. - * - * Results: - * Tcl result code (error if command token does not indicate an ensemble - * or the mapping - if non-NULL - is not a dict). - * - * Side effects: - * The ensemble is updated and marked for recompilation. - * - *---------------------------------------------------------------------- - */ + } else if (objc == 3) { + /* + * Look for a flag controlling the lookup. + */ -int -Tcl_SetEnsembleMappingDict( - Tcl_Interp *interp, - Tcl_Command token, - Tcl_Obj *mapDict) -{ - Command *cmdPtr = (Command *) token; - EnsembleConfig *ensemblePtr; - Tcl_Obj *oldDict; + if (Tcl_GetIndexFromObj(interp, objv[1], opts, "option", 0, + &lookupType) != TCL_OK) { + /* + * Preserve old style of error message! + */ - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { - if (interp != NULL) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); - } - return TCL_ERROR; - } - if (mapDict != NULL) { - int size; - if (Tcl_DictObjSize(interp, mapDict, &size) != TCL_OK) { - return TCL_ERROR; - } - if (size < 1) { - mapDict = NULL; + Tcl_ResetResult(interp); + goto badArgs; } } - ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData; - oldDict = ensemblePtr->subcommandDict; - ensemblePtr->subcommandDict = mapDict; - if (mapDict != NULL) { - Tcl_IncrRefCount(mapDict); - } - if (oldDict != NULL) { - TclDecrRefCount(oldDict); - } - - /* - * Trigger an eventual recomputation of the ensemble command set. Note - * that this is slightly tricky, as it means that we are not actually - * counting the number of namespace export actions, but it is the simplest - * way to go! - */ - - ensemblePtr->nsPtr->exportLookupEpoch++; - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetEnsembleUnknownHandler -- - * - * Set the unknown handler for a particular ensemble. - * - * Results: - * Tcl result code (error if command token does not indicate an ensemble - * or the unknown handler - if non-NULL - is not a list). - * - * Side effects: - * The ensemble is updated and marked for recompilation. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_SetEnsembleUnknownHandler( - Tcl_Interp *interp, - Tcl_Command token, - Tcl_Obj *unknownList) -{ - Command *cmdPtr = (Command *) token; - EnsembleConfig *ensemblePtr; - Tcl_Obj *oldList; + TclNewObj(resultPtr); + switch (lookupType) { + case 0: { /* -command */ + Tcl_Command cmd = Tcl_GetCommandFromObj(interp, objv[objc-1]); - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { - if (interp != NULL) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); + if (cmd != NULL) { + Tcl_GetCommandFullName(interp, cmd, resultPtr); } - return TCL_ERROR; + break; } - if (unknownList != NULL) { - int length; + case 1: { /* -variable */ + Tcl_Var var = Tcl_FindNamespaceVar(interp, + TclGetString(objv[objc-1]), NULL, /*flags*/ 0); - if (Tcl_ListObjLength(interp, unknownList, &length) != TCL_OK) { - return TCL_ERROR; - } - if (length < 1) { - unknownList = NULL; + if (var != NULL) { + Tcl_GetVariableFullName(interp, var, resultPtr); } + break; } - - ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData; - oldList = ensemblePtr->unknownHandler; - ensemblePtr->unknownHandler = unknownList; - if (unknownList != NULL) { - Tcl_IncrRefCount(unknownList); - } - if (oldList != NULL) { - TclDecrRefCount(oldList); } - - /* - * Trigger an eventual recomputation of the ensemble command set. Note - * that this is slightly tricky, as it means that we are not actually - * counting the number of namespace export actions, but it is the simplest - * way to go! - */ - - ensemblePtr->nsPtr->exportLookupEpoch++; - + Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * - * Tcl_SetEnsembleFlags -- + * FreeNsNameInternalRep -- * - * Set the flags for a particular ensemble. + * Frees the resources associated with a nsName object's internal + * representation. * * Results: - * Tcl result code (error if command token does not indicate an - * ensemble). + * None. * * Side effects: - * The ensemble is updated and marked for recompilation. + * Decrements the ref count of any Namespace structure pointed to by the + * nsName's internal representation. If there are no more references to + * the namespace, it's structure will be freed. * *---------------------------------------------------------------------- */ -int -Tcl_SetEnsembleFlags( - Tcl_Interp *interp, - Tcl_Command token, - int flags) +static void +FreeNsNameInternalRep( + register Tcl_Obj *objPtr) /* nsName object with internal representation + * to free. */ { - Command *cmdPtr = (Command *) token; - EnsembleConfig *ensemblePtr; - - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { - if (interp != NULL) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); - } - return TCL_ERROR; - } - - ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData; - /* - * This API refuses to set the ENS_DEAD flag... - */ - ensemblePtr->flags &= ENS_DEAD; - ensemblePtr->flags |= flags & ~ENS_DEAD; + ResolvedNsName *resNamePtr = objPtr->internalRep.twoPtrValue.ptr1; /* - * Trigger an eventual recomputation of the ensemble command set. Note - * that this is slightly tricky, as it means that we are not actually - * counting the number of namespace export actions, but it is the simplest - * way to go! + * Decrement the reference count of the namespace. If there are no more + * references, free it up. */ - ensemblePtr->nsPtr->exportLookupEpoch++; - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetEnsembleSubcommandList -- - * - * Get the list of subcommands associated with a particular ensemble. - * - * Results: - * Tcl result code (error if command token does not indicate an - * ensemble). The list of subcommands is returned by updating the - * variable pointed to by the last parameter (NULL if this is to be - * derived from the mapping dictionary or the associated namespace's - * exported commands). - * - * Side effects: - * None - * - *---------------------------------------------------------------------- - */ - -int -Tcl_GetEnsembleSubcommandList( - Tcl_Interp *interp, - Tcl_Command token, - Tcl_Obj **subcmdListPtr) -{ - Command *cmdPtr = (Command *) token; - EnsembleConfig *ensemblePtr; + resNamePtr->refCount--; + if (resNamePtr->refCount == 0) { + /* + * Decrement the reference count for the cached namespace. If the + * namespace is dead, and there are no more references to it, free + * it. + */ - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { - if (interp != NULL) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); - } - return TCL_ERROR; + TclNsDecrRefCount(resNamePtr->nsPtr); + ckfree(resNamePtr); } - - ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData; - *subcmdListPtr = ensemblePtr->subcmdList; - return TCL_OK; + objPtr->typePtr = NULL; } /* *---------------------------------------------------------------------- * - * Tcl_GetEnsembleMappingDict -- + * DupNsNameInternalRep -- * - * Get the command mapping dictionary associated with a particular - * ensemble. + * Initializes the internal representation of a nsName object to a copy + * of the internal representation of another nsName object. * * Results: - * Tcl result code (error if command token does not indicate an - * ensemble). The mapping dict is returned by updating the variable - * pointed to by the last parameter (NULL if none is installed). + * None. * * Side effects: - * None + * copyPtr's internal rep is set to refer to the same namespace + * referenced by srcPtr's internal rep. Increments the ref count of the + * ResolvedNsName structure used to hold the namespace reference. * *---------------------------------------------------------------------- */ -int -Tcl_GetEnsembleMappingDict( - Tcl_Interp *interp, - Tcl_Command token, - Tcl_Obj **mapDictPtr) +static void +DupNsNameInternalRep( + Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ + register Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - Command *cmdPtr = (Command *) token; - EnsembleConfig *ensemblePtr; - - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { - if (interp != NULL) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); - } - return TCL_ERROR; - } + ResolvedNsName *resNamePtr = srcPtr->internalRep.twoPtrValue.ptr1; - ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData; - *mapDictPtr = ensemblePtr->subcommandDict; - return TCL_OK; + copyPtr->internalRep.twoPtrValue.ptr1 = resNamePtr; + resNamePtr->refCount++; + copyPtr->typePtr = &nsNameType; } /* *---------------------------------------------------------------------- * - * Tcl_GetEnsembleUnknownHandler -- + * SetNsNameFromAny -- * - * Get the unknown handler associated with a particular ensemble. + * Attempt to generate a nsName internal representation for a Tcl object. * * Results: - * Tcl result code (error if command token does not indicate an - * ensemble). The unknown handler is returned by updating the variable - * pointed to by the last parameter (NULL if no handler is installed). + * Returns TCL_OK if the value could be converted to a proper namespace + * reference. Otherwise, it returns TCL_ERROR, along with an error + * message in the interpreter's result object. * * Side effects: - * None + * If successful, the object is made a nsName object. Its internal rep is + * set to point to a ResolvedNsName, which contains a cached pointer to + * the Namespace. Reference counts are kept on both the ResolvedNsName + * and the Namespace, so we can keep track of their usage and free them + * when appropriate. * *---------------------------------------------------------------------- */ -int -Tcl_GetEnsembleUnknownHandler( - Tcl_Interp *interp, - Tcl_Command token, - Tcl_Obj **unknownListPtr) +static int +SetNsNameFromAny( + Tcl_Interp *interp, /* Points to the namespace in which to resolve + * name. Also used for error reporting if not + * NULL. */ + register Tcl_Obj *objPtr) /* The object to convert. */ { - Command *cmdPtr = (Command *) token; - EnsembleConfig *ensemblePtr; + const char *dummy; + Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr; + register ResolvedNsName *resNamePtr; + const char *name; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { - if (interp != NULL) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); - } + if (interp == NULL) { return TCL_ERROR; } - ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData; - *unknownListPtr = ensemblePtr->unknownHandler; - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetEnsembleFlags -- - * - * Get the flags for a particular ensemble. - * - * Results: - * Tcl result code (error if command token does not indicate an - * ensemble). The flags are returned by updating the variable pointed to - * by the last parameter. - * - * Side effects: - * None - * - *---------------------------------------------------------------------- - */ - -int -Tcl_GetEnsembleFlags( - Tcl_Interp *interp, - Tcl_Command token, - int *flagsPtr) -{ - Command *cmdPtr = (Command *) token; - EnsembleConfig *ensemblePtr; - - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { - if (interp != NULL) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); - } - return TCL_ERROR; - } + name = TclGetString(objPtr); + TclGetNamespaceForQualName(interp, name, NULL, TCL_FIND_ONLY_NS, + &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); - ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData; - *flagsPtr = ensemblePtr->flags; - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetEnsembleNamespace -- - * - * Get the namespace associated with a particular ensemble. - * - * Results: - * Tcl result code (error if command token does not indicate an - * ensemble). Namespace is returned by updating the variable pointed to - * by the last parameter. - * - * Side effects: - * None - * - *---------------------------------------------------------------------- - */ + /* + * If we found a namespace, then create a new ResolvedNsName structure + * that holds a reference to it. + */ -int -Tcl_GetEnsembleNamespace( - Tcl_Interp *interp, - Tcl_Command token, - Tcl_Namespace **namespacePtrPtr) -{ - Command *cmdPtr = (Command *) token; - EnsembleConfig *ensemblePtr; + if ((nsPtr == NULL) || (nsPtr->flags & NS_DYING)) { + /* + * Our failed lookup proves any previously cached nsName intrep is no + * longer valid. Get rid of it so we no longer waste memory storing + * it, nor time determining its invalidity again and again. + */ - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { - if (interp != NULL) { - Tcl_AppendResult(interp, "command is not an ensemble", NULL); + if (objPtr->typePtr == &nsNameType) { + TclFreeIntRep(objPtr); } return TCL_ERROR; } - ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData; - *namespacePtrPtr = (Tcl_Namespace *) ensemblePtr->nsPtr; + nsPtr->refCount++; + resNamePtr = ckalloc(sizeof(ResolvedNsName)); + resNamePtr->nsPtr = nsPtr; + if ((name[0] == ':') && (name[1] == ':')) { + resNamePtr->refNsPtr = NULL; + } else { + resNamePtr->refNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + } + resNamePtr->refCount = 1; + TclFreeIntRep(objPtr); + objPtr->internalRep.twoPtrValue.ptr1 = resNamePtr; + objPtr->typePtr = &nsNameType; return TCL_OK; } /* *---------------------------------------------------------------------- * - * Tcl_FindEnsemble -- + * TclGetNamespaceCommandTable -- * - * Given a command name, get the ensemble token for it, allowing for - * [namespace import]s. [Bug 1017022] + * Returns the hash table of commands. * * Results: - * The token for the ensemble command with the given name, or NULL if the - * command either does not exist or is not an ensemble (when an error - * message will be written into the interp if thats non-NULL). + * Pointer to the hash table. * * Side effects: - * None + * None. * *---------------------------------------------------------------------- */ -Tcl_Command -Tcl_FindEnsemble( - Tcl_Interp *interp, /* Where to do the lookup, and where to write - * the errors if TCL_LEAVE_ERR_MSG is set in - * the flags. */ - Tcl_Obj *cmdNameObj, /* Name of command to look up. */ - int flags) /* Either 0 or TCL_LEAVE_ERR_MSG; other flags - * are probably not useful. */ +Tcl_HashTable * +TclGetNamespaceCommandTable( + Tcl_Namespace *nsPtr) { - Command *cmdPtr; - - cmdPtr = (Command *) - Tcl_FindCommand(interp, TclGetString(cmdNameObj), NULL, flags); - if (cmdPtr == NULL) { - return NULL; - } - - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { - /* - * Reuse existing infrastructure for following import link chains - * rather than duplicating it. - */ - - cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); - - if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd) { - if (flags & TCL_LEAVE_ERR_MSG) { - Tcl_AppendResult(interp, "\"", TclGetString(cmdNameObj), - "\" is not an ensemble command", NULL); - } - return NULL; - } - } - - return (Tcl_Command) cmdPtr; + return &((Namespace *) nsPtr)->cmdTable; } /* *---------------------------------------------------------------------- * - * Tcl_IsEnsemble -- + * TclGetNamespaceChildTable -- * - * Simple test for ensemble-hood that takes into account imported - * ensemble commands as well. + * Returns the hash table of child namespaces. * * Results: - * Boolean value + * Pointer to the hash table. * * Side effects: - * None + * Might allocate memory. * *---------------------------------------------------------------------- */ -int -Tcl_IsEnsemble( - Tcl_Command token) +Tcl_HashTable * +TclGetNamespaceChildTable( + Tcl_Namespace *nsPtr) { - Command *cmdPtr = (Command *) token; - if (cmdPtr->objProc == NsEnsembleImplementationCmd) { - return 1; - } - cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); - if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd) { - return 0; - } - return 1; + Namespace *nPtr = (Namespace *) nsPtr; +#ifndef BREAK_NAMESPACE_COMPAT + return &nPtr->childTable; +#else + if (nPtr->childTablePtr == NULL) { + nPtr->childTablePtr = ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(nPtr->childTablePtr, TCL_STRING_KEYS); + } + return nPtr->childTablePtr; +#endif } /* *---------------------------------------------------------------------- * - * NsEnsembleImplementationCmd -- + * TclLogCommandInfo -- * - * Implements an ensemble of commands (being those exported by a - * namespace other than the global namespace) as a command with the same - * (short) name as the namespace in the parent namespace. + * This function is invoked after an error occurs in an interpreter. It + * adds information to iPtr->errorInfo/errorStack fields to describe the + * command that was being executed when the error occurred. When pc and + * tosPtr are non-NULL, conveying a bytecode execution "inner context", + * and the offending instruction is suitable, that inner context is + * recorded in errorStack. * * Results: - * A standard Tcl result code. Will be TCL_ERROR if the command is not an - * unambiguous prefix of any command exported by the ensemble's - * namespace. + * None. * * Side effects: - * Depends on the command within the namespace that gets executed. If the - * ensemble itself returns TCL_ERROR, a descriptive error message will be - * placed in the interpreter's result. + * Information about the command is added to errorInfo/errorStack and the + * line number stored internally in the interpreter is set. * *---------------------------------------------------------------------- */ -static int -NsEnsembleImplementationCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *CONST objv[]) +void +TclLogCommandInfo( + Tcl_Interp *interp, /* Interpreter in which to log information. */ + const char *script, /* First character in script containing + * command (must be <= command). */ + const char *command, /* First character in command that generated + * the error. */ + int length, /* Number of bytes in command (-1 means use + * all bytes up to first null byte). */ + const unsigned char *pc, /* Current pc of bytecode execution context */ + Tcl_Obj **tosPtr) /* Current stack of bytecode execution + * context */ { - EnsembleConfig *ensemblePtr = (EnsembleConfig *) clientData; - /* The ensemble itself. */ - Tcl_Obj **tempObjv; /* Space used to construct the list of - * arguments to pass to the command that - * implements the ensemble subcommand. */ - int result; /* The result of the subcommand execution. */ - Tcl_Obj *prefixObj; /* An object containing the prefix words of - * the command that implements the - * subcommand. */ - Tcl_HashEntry *hPtr; /* Used for efficient lookup of fully - * specified but not yet cached command - * names. */ - Tcl_Obj **prefixObjv; /* The list of objects to substitute in as the - * target command prefix. */ - int prefixObjc; /* Size of prefixObjv of course! */ - int reparseCount = 0; /* Number of reparses. */ - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?argument ...?"); - return TCL_ERROR; - } - - restartEnsembleParse: - if (ensemblePtr->nsPtr->flags & NS_DEAD) { - /* - * Don't know how we got here, but make things give up quickly. - */ - - if (!Tcl_InterpDeleted(interp)) { - Tcl_AppendResult(interp, - "ensemble activated for deleted namespace", NULL); - } - return TCL_ERROR; - } + register const char *p; + Interp *iPtr = (Interp *) interp; + int overflow, limit = 150; + Var *varPtr, *arrayPtr; - if (ensemblePtr->epoch != ensemblePtr->nsPtr->exportLookupEpoch) { - ensemblePtr->epoch = ensemblePtr->nsPtr->exportLookupEpoch; - BuildEnsembleConfig(ensemblePtr); - } else { + if (iPtr->flags & ERR_ALREADY_LOGGED) { /* - * Table of subcommands is still valid; therefore there might be a - * valid cache of discovered information which we can reuse. Do the - * check here, and if we're still valid, we can jump straight to the - * part where we do the invocation of the subcommand. + * Someone else has already logged error information for this command; + * we shouldn't add anything more. */ - if (objv[1]->typePtr == &ensembleCmdType) { - EnsembleCmdRep *ensembleCmd = (EnsembleCmdRep *) - objv[1]->internalRep.otherValuePtr; - if (ensembleCmd->nsPtr == ensemblePtr->nsPtr && - ensembleCmd->epoch == ensemblePtr->epoch && - ensembleCmd->token == ensemblePtr->token) { - prefixObj = ensembleCmd->realPrefixObj; - Tcl_IncrRefCount(prefixObj); - goto runResultingSubcommand; - } - } + return; } - /* - * Look in the hashtable for the subcommand name; this is the fastest way - * of all. - */ - - hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable, - TclGetString(objv[1])); - if (hPtr != NULL) { - char *fullName = Tcl_GetHashKey(&ensemblePtr->subcommandTable, hPtr); - prefixObj = (Tcl_Obj *) Tcl_GetHashValue(hPtr); - - /* - * Cache for later in the subcommand object. - */ - - MakeCachedEnsembleCommand(objv[1], ensemblePtr, fullName, prefixObj); - } else if (!(ensemblePtr->flags & TCL_ENSEMBLE_PREFIX)) { - /* - * Can't find and we are prohibited from using unambiguous prefixes. - */ - - goto unknownOrAmbiguousSubcommand; - } else { + if (command != NULL) { /* - * If we've not already confirmed the command with the hash as part of - * building our export table, we need to scan the sorted array for - * matches. + * Compute the line number where the error occurred. */ - char *subcmdName; /* Name of the subcommand, or unique prefix of - * it (will be an error for a non-unique - * prefix). */ - char *fullName = NULL; /* Full name of the subcommand. */ - int stringLength, i; - int tableLength = ensemblePtr->subcommandTable.numEntries; - - subcmdName = TclGetString(objv[1]); - stringLength = objv[1]->length; - for (i=0 ; i<tableLength ; i++) { - register int cmp = strncmp(subcmdName, - ensemblePtr->subcommandArrayPtr[i], - (unsigned) stringLength); - if (cmp == 0) { - if (fullName != NULL) { - /* - * Since there's never the exact-match case to worry about - * (hash search filters this), getting here indicates that - * our subcommand is an ambiguous prefix of (at least) two - * exported subcommands, which is an error case. - */ - - goto unknownOrAmbiguousSubcommand; - } - fullName = ensemblePtr->subcommandArrayPtr[i]; - } else if (cmp < 0) { - /* - * Because we are searching a sorted table, we can now stop - * searching because we have gone past anything that could - * possibly match. - */ - - break; - } - } - if (fullName == NULL) { - /* - * The subcommand is not a prefix of anything, so bail out! - */ - - goto unknownOrAmbiguousSubcommand; - } - hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable, fullName); - if (hPtr == NULL) { - Tcl_Panic("full name %s not found in supposedly synchronized hash", - fullName); - } - prefixObj = (Tcl_Obj *) Tcl_GetHashValue(hPtr); - - /* - * Cache for later in the subcommand object. - */ - - MakeCachedEnsembleCommand(objv[1], ensemblePtr, fullName, prefixObj); - } - - /* - * Do the real work of execution of the subcommand by building an array of - * objects (note that this is potentially not the same length as the - * number of arguments to this ensemble command), populating it and then - * feeding it back through the main command-lookup engine. In theory, we - * could look up the command in the namespace ourselves, as we already - * have the namespace in which it is guaranteed to exist, but we don't do - * that (the cacheing of the command object used should help with that.) - */ - - Tcl_IncrRefCount(prefixObj); - runResultingSubcommand: - { - Interp *iPtr = (Interp *) interp; - int isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL); - - Tcl_ListObjGetElements(NULL, prefixObj, &prefixObjc, &prefixObjv); - if (isRootEnsemble) { - iPtr->ensembleRewrite.sourceObjs = objv; - iPtr->ensembleRewrite.numRemovedObjs = 2; - iPtr->ensembleRewrite.numInsertedObjs = prefixObjc; - } else { - int ni = iPtr->ensembleRewrite.numInsertedObjs; - if (ni < 2) { - iPtr->ensembleRewrite.numRemovedObjs += 2 - ni; - iPtr->ensembleRewrite.numInsertedObjs += prefixObjc - 1; - } else { - iPtr->ensembleRewrite.numInsertedObjs += prefixObjc - 2; + iPtr->errorLine = 1; + for (p = script; p != command; p++) { + if (*p == '\n') { + iPtr->errorLine++; } } - tempObjv = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *)*(objc-2+prefixObjc)); - memcpy(tempObjv, prefixObjv, sizeof(Tcl_Obj *) * prefixObjc); - memcpy(tempObjv+prefixObjc, objv+2, sizeof(Tcl_Obj *) * (objc-2)); - result = Tcl_EvalObjv(interp, objc-2+prefixObjc, tempObjv, - TCL_EVAL_INVOKE); - Tcl_DecrRefCount(prefixObj); - ckfree((char *)tempObjv); - if (isRootEnsemble) { - iPtr->ensembleRewrite.sourceObjs = NULL; - iPtr->ensembleRewrite.numRemovedObjs = 0; - iPtr->ensembleRewrite.numInsertedObjs = 0; - } - return result; - } - - unknownOrAmbiguousSubcommand: - /* - * Have not been able to match the subcommand asked for with a real - * subcommand that we export. See whether a handler has been registered - * for dealing with this situation. Will only call (at most) once for any - * particular ensemble invocation. - */ - - if (ensemblePtr->unknownHandler != NULL && reparseCount++ < 1) { - int paramc, i; - Tcl_Obj **paramv, *unknownCmd, *ensObj; - unknownCmd = Tcl_DuplicateObj(ensemblePtr->unknownHandler); - TclNewObj(ensObj); - Tcl_GetCommandFullName(interp, ensemblePtr->token, ensObj); - Tcl_ListObjAppendElement(NULL, unknownCmd, ensObj); - for (i=1 ; i<objc ; i++) { - Tcl_ListObjAppendElement(NULL, unknownCmd, objv[i]); + if (length < 0) { + length = strlen(command); } - Tcl_ListObjGetElements(NULL, unknownCmd, ¶mc, ¶mv); - Tcl_Preserve(ensemblePtr); - Tcl_IncrRefCount(unknownCmd); - result = Tcl_EvalObjv(interp, paramc, paramv, 0); - if (result == TCL_OK) { - prefixObj = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(prefixObj); - Tcl_DecrRefCount(unknownCmd); - Tcl_Release(ensemblePtr); - Tcl_ResetResult(interp); - if (ensemblePtr->flags & ENS_DEAD) { - Tcl_DecrRefCount(prefixObj); - Tcl_SetResult(interp, - "unknown subcommand handler deleted its ensemble", - TCL_STATIC); - return TCL_ERROR; - } + overflow = (length > limit); + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n %s\n\"%.*s%s\"", ((iPtr->errorInfo == NULL) + ? "while executing" : "invoked from within"), + (overflow ? limit : length), command, + (overflow ? "..." : ""))); + varPtr = TclObjLookupVarEx(interp, iPtr->eiVar, NULL, TCL_GLOBAL_ONLY, + NULL, 0, 0, &arrayPtr); + if ((varPtr == NULL) || !TclIsVarTraced(varPtr)) { /* - * Namespace is still there. Check if the result is a valid list. - * If it is, and it is non-empty, that list is what we are using - * as our replacement. + * Should not happen. */ - if (Tcl_ListObjLength(interp, prefixObj, &prefixObjc) != TCL_OK) { - Tcl_DecrRefCount(prefixObj); - Tcl_AddErrorInfo(interp, - "\n while parsing result of ensemble unknown subcommand handler"); - return TCL_ERROR; - } - if (prefixObjc > 0) { - goto runResultingSubcommand; - } + return; + } else { + Tcl_HashEntry *hPtr + = Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr); + VarTrace *tracePtr = Tcl_GetHashValue(hPtr); - /* - * Namespace alive & empty result => reparse. - */ + if (tracePtr->traceProc != EstablishErrorInfoTraces) { + /* + * The most recent trace set on ::errorInfo is not the one the + * core itself puts on last. This means some other code is + * tracing the variable, and the additional trace(s) might be + * write traces that expect the timing of writes to + * ::errorInfo that existed Tcl releases before 8.5. To + * satisfy that compatibility need, we write the current + * -errorinfo value to the ::errorInfo variable. + */ - Tcl_DecrRefCount(prefixObj); - goto restartEnsembleParse; - } - if (!Tcl_InterpDeleted(interp)) { - if (result != TCL_ERROR) { - Tcl_ResetResult(interp); - Tcl_SetResult(interp, - "unknown subcommand handler returned bad code: ", - TCL_STATIC); - switch (result) { - case TCL_RETURN: - Tcl_AppendResult(interp, "return", NULL); - break; - case TCL_BREAK: - Tcl_AppendResult(interp, "break", NULL); - break; - case TCL_CONTINUE: - Tcl_AppendResult(interp, "continue", NULL); - break; - default: { - char buf[TCL_INTEGER_SPACE]; - - sprintf(buf, "%d", result); - Tcl_AppendResult(interp, buf, NULL); - } - } - Tcl_AddErrorInfo(interp, - "\n result of ensemble unknown subcommand handler: "); - Tcl_AddErrorInfo(interp, TclGetString(unknownCmd)); - } else { - Tcl_AddErrorInfo(interp, - "\n (ensemble unknown subcommand handler)"); + Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, iPtr->errorInfo, + TCL_GLOBAL_ONLY); } } - Tcl_DecrRefCount(unknownCmd); - Tcl_Release(ensemblePtr); - return TCL_ERROR; } /* - * Cannot determine what subcommand to hand off to, so generate a - * (standard) failure message. Note the one odd case compared with - * standard ensemble-like command, which is where a namespace has no - * exported commands at all... + * TIP #348 */ - Tcl_ResetResult(interp); - if (ensemblePtr->subcommandTable.numEntries == 0) { - Tcl_AppendResult(interp, "unknown subcommand \"",TclGetString(objv[1]), - "\": namespace ", ensemblePtr->nsPtr->fullName, - " does not export any commands", NULL); - return TCL_ERROR; - } - Tcl_AppendResult(interp, "unknown ", - (ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? "or ambiguous " : ""), - "subcommand \"", TclGetString(objv[1]), "\": must be ", NULL); - if (ensemblePtr->subcommandTable.numEntries == 1) { - Tcl_AppendResult(interp, ensemblePtr->subcommandArrayPtr[0], NULL); - } else { - int i; - for (i=0 ; i<ensemblePtr->subcommandTable.numEntries-1 ; i++) { - Tcl_AppendResult(interp, - ensemblePtr->subcommandArrayPtr[i], ", ", NULL); - } - Tcl_AppendResult(interp, "or ", - ensemblePtr->subcommandArrayPtr[i], NULL); + if (Tcl_IsShared(iPtr->errorStack)) { + Tcl_Obj *newObj; + + newObj = Tcl_DuplicateObj(iPtr->errorStack); + Tcl_DecrRefCount(iPtr->errorStack); + Tcl_IncrRefCount(newObj); + iPtr->errorStack = newObj; } - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * MakeCachedEnsembleCommand -- - * - * Cache what we've computed so far; it's not nice to repeatedly copy - * strings about. Note that to do this, we start by deleting any old - * representation that there was (though if it was an out of date - * ensemble rep, we can skip some of the deallocation process.) - * - * Results: - * None - * - * Side effects: - * Alters the internal representation of the first object parameter. - * - *---------------------------------------------------------------------- - */ -static void -MakeCachedEnsembleCommand( - Tcl_Obj *objPtr, - EnsembleConfig *ensemblePtr, - CONST char *subcommandName, - Tcl_Obj *prefixObjPtr) -{ - register EnsembleCmdRep *ensembleCmd; - int length; + if (iPtr->resetErrorStack) { + int len; + + iPtr->resetErrorStack = 0; + Tcl_ListObjLength(interp, iPtr->errorStack, &len); - if (objPtr->typePtr == &ensembleCmdType) { - ensembleCmd = (EnsembleCmdRep *) objPtr->internalRep.otherValuePtr; - Tcl_DecrRefCount(ensembleCmd->realPrefixObj); - ensembleCmd->nsPtr->refCount--; - if ((ensembleCmd->nsPtr->refCount == 0) - && (ensembleCmd->nsPtr->flags & NS_DEAD)) { - NamespaceFree(ensembleCmd->nsPtr); - } - ckfree(ensembleCmd->fullSubcmdName); - } else { /* - * Kill the old internal rep, and replace it with a brand new one of - * our own. + * Reset while keeping the list intrep as much as possible. */ - TclFreeIntRep(objPtr); - ensembleCmd = (EnsembleCmdRep *) ckalloc(sizeof(EnsembleCmdRep)); - objPtr->internalRep.otherValuePtr = (void *) ensembleCmd; - objPtr->typePtr = &ensembleCmdType; - } - - /* - * Populate the internal rep. - */ + Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL); + if (pc != NULL) { + Tcl_Obj *innerContext; - ensembleCmd->nsPtr = ensemblePtr->nsPtr; - ensembleCmd->epoch = ensemblePtr->epoch; - ensembleCmd->token = ensemblePtr->token; - ensemblePtr->nsPtr->refCount++; - ensembleCmd->realPrefixObj = prefixObjPtr; - length = strlen(subcommandName)+1; - ensembleCmd->fullSubcmdName = ckalloc((unsigned) length); - memcpy(ensembleCmd->fullSubcmdName, subcommandName, (unsigned) length); - Tcl_IncrRefCount(ensembleCmd->realPrefixObj); -} - -/* - *---------------------------------------------------------------------- - * - * DeleteEnsembleConfig -- - * - * Destroys the data structure used to represent an ensemble. This is - * called when the ensemble's command is deleted (which happens - * automatically if the ensemble's namespace is deleted.) Maintainers - * should note that ensembles should be deleted by deleting their - * commands. - * - * Results: - * None. - * - * Side effects: - * Memory is (eventually) deallocated. - * - *---------------------------------------------------------------------- - */ - -static void -DeleteEnsembleConfig( - ClientData clientData) -{ - EnsembleConfig *ensemblePtr = (EnsembleConfig *)clientData; - Namespace *nsPtr = ensemblePtr->nsPtr; - Tcl_HashSearch search; - Tcl_HashEntry *hEnt; - - /* - * Unlink from the ensemble chain if it has not been marked as having been - * done already. - */ - - if (ensemblePtr->next != ensemblePtr) { - EnsembleConfig *ensPtr = (EnsembleConfig *) nsPtr->ensembles; - if (ensPtr == ensemblePtr) { - nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr->next; - } else { - while (ensPtr != NULL) { - if (ensPtr->next == ensemblePtr) { - ensPtr->next = ensemblePtr->next; - break; - } - ensPtr = ensPtr->next; + innerContext = TclGetInnerContext(interp, pc, tosPtr); + if (innerContext != NULL) { + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, + iPtr->innerLiteral); + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, innerContext); } + } else if (command != NULL) { + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, + iPtr->innerLiteral); + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, + Tcl_NewStringObj(command, length)); } - } - - /* - * Mark the namespace as dead so code that uses Tcl_Preserve() can tell - * whether disaster happened anyway. - */ - - ensemblePtr->flags |= ENS_DEAD; - - /* - * Kill the pointer-containing fields. - */ - - if (ensemblePtr->subcommandTable.numEntries != 0) { - ckfree((char *)ensemblePtr->subcommandArrayPtr); - } - hEnt = Tcl_FirstHashEntry(&ensemblePtr->subcommandTable, &search); - while (hEnt != NULL) { - Tcl_Obj *prefixObj = (Tcl_Obj *) Tcl_GetHashValue(hEnt); - Tcl_DecrRefCount(prefixObj); - hEnt = Tcl_NextHashEntry(&search); - } - Tcl_DeleteHashTable(&ensemblePtr->subcommandTable); - if (ensemblePtr->subcmdList != NULL) { - Tcl_DecrRefCount(ensemblePtr->subcmdList); - } - if (ensemblePtr->subcommandDict != NULL) { - Tcl_DecrRefCount(ensemblePtr->subcommandDict); - } - if (ensemblePtr->unknownHandler != NULL) { - Tcl_DecrRefCount(ensemblePtr->unknownHandler); - } - - /* - * Arrange for the structure to be reclaimed. Note that this is complex - * because we have to make sure that we can react sensibly when an - * ensemble is deleted during the process of initialising the ensemble - * (especially the unknown callback.) - */ - - Tcl_EventuallyFree((ClientData) ensemblePtr, TCL_DYNAMIC); -} - -/* - *---------------------------------------------------------------------- - * - * BuildEnsembleConfig -- - * - * Create the internal data structures that describe how an ensemble - * looks, being a hash mapping from the full command name to the Tcl list - * that describes the implementation prefix words, and a sorted array of - * all the full command names to allow for reasonably efficient - * unambiguous prefix handling. - * - * Results: - * None. - * - * Side effects: - * Reallocates and rebuilds the hash table and array stored at the - * ensemblePtr argument. For large ensembles or large namespaces, this is - * a potentially expensive operation. - * - *---------------------------------------------------------------------- - */ - -static void -BuildEnsembleConfig( - EnsembleConfig *ensemblePtr) -{ - Tcl_HashSearch search; /* Used for scanning the set of commands in - * the namespace that backs up this - * ensemble. */ - int i, j, isNew; - Tcl_HashTable *hash = &ensemblePtr->subcommandTable; - Tcl_HashEntry *hPtr; + } - if (hash->numEntries != 0) { + if (!iPtr->framePtr->objc) { /* - * Remove pre-existing table. + * Special frame, nothing to report. */ - - Tcl_HashSearch search; - - ckfree((char *)ensemblePtr->subcommandArrayPtr); - hPtr = Tcl_FirstHashEntry(hash, &search); - while (hPtr != NULL) { - Tcl_Obj *prefixObj = (Tcl_Obj *) Tcl_GetHashValue(hPtr); - Tcl_DecrRefCount(prefixObj); - hPtr = Tcl_NextHashEntry(&search); - } - Tcl_DeleteHashTable(hash); - Tcl_InitHashTable(hash, TCL_STRING_KEYS); - } - - /* - * See if we've got an export list. If so, we will only export exactly - * those commands, which may be either implemented by the prefix in the - * subcommandDict or mapped directly onto the namespace's commands. - */ - - if (ensemblePtr->subcmdList != NULL) { - Tcl_Obj **subcmdv, *target, *cmdObj, *cmdPrefixObj; - int subcmdc; - - Tcl_ListObjGetElements(NULL, ensemblePtr->subcmdList, &subcmdc, - &subcmdv); - for (i=0 ; i<subcmdc ; i++) { - char *name = TclGetString(subcmdv[i]); - - hPtr = Tcl_CreateHashEntry(hash, name, &isNew); - - /* Skip non-unique cases. */ - if (!isNew) { - continue; - } - - /* - * Look in our dictionary (if present) for the command. - */ - - if (ensemblePtr->subcommandDict != NULL) { - Tcl_DictObjGet(NULL, ensemblePtr->subcommandDict, subcmdv[i], - &target); - if (target != NULL) { - Tcl_SetHashValue(hPtr, (ClientData) target); - Tcl_IncrRefCount(target); - continue; - } - } - - /* - * Not there, so map onto the namespace. Note in this case that we - * do not guarantee that the command is actually there; that is - * the programmer's responsibility (or [::unknown] of course). - */ - - cmdObj = Tcl_NewStringObj(ensemblePtr->nsPtr->fullName, -1); - if (ensemblePtr->nsPtr->parentPtr != NULL) { - Tcl_AppendStringsToObj(cmdObj, "::", name, NULL); - } else { - Tcl_AppendStringsToObj(cmdObj, name, NULL); - } - cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); - Tcl_SetHashValue(hPtr, (ClientData) cmdPrefixObj); - Tcl_IncrRefCount(cmdPrefixObj); - } - } else if (ensemblePtr->subcommandDict != NULL) { + } else if (iPtr->varFramePtr != iPtr->framePtr) { /* - * No subcmd list, but we do have a mapping dictionary so we should - * use the keys of that. Convert the dictionary's contents into the - * form required for the ensemble's internal hashtable. + * uplevel case, [lappend errorstack UP $relativelevel] */ - Tcl_DictSearch dictSearch; - Tcl_Obj *keyObj, *valueObj; - int done; - - Tcl_DictObjFirst(NULL, ensemblePtr->subcommandDict, &dictSearch, - &keyObj, &valueObj, &done); - while (!done) { - char *name = TclGetString(keyObj); - - hPtr = Tcl_CreateHashEntry(hash, name, &isNew); - Tcl_SetHashValue(hPtr, (ClientData) valueObj); - Tcl_IncrRefCount(valueObj); - Tcl_DictObjNext(&dictSearch, &keyObj, &valueObj, &done); - } - } else { + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->upLiteral); + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewIntObj( + iPtr->framePtr->level - iPtr->varFramePtr->level)); + } else if (iPtr->framePtr != iPtr->rootFramePtr) { /* - * Discover what commands are actually exported by the namespace. - * What we have is an array of patterns and a hash table whose keys - * are the command names exported by the namespace (the contents do - * not matter here.) We must find out what commands are actually - * exported by filtering each command in the namespace against each of - * the patterns in the export list. Note that we use an intermediate - * hash table to make memory management easier, and because that makes - * exact matching far easier too. - * - * Suggestion for future enhancement: compute the unique prefixes and - * place them in the hash too, which should make for even faster - * matching. + * normal case, [lappend errorstack CALL [info level 0]] */ - hPtr = Tcl_FirstHashEntry(&ensemblePtr->nsPtr->cmdTable, &search); - for (; hPtr!= NULL ; hPtr=Tcl_NextHashEntry(&search)) { - char *nsCmdName = /* Name of command in namespace. */ - Tcl_GetHashKey(&ensemblePtr->nsPtr->cmdTable, hPtr); - - for (i=0 ; i<ensemblePtr->nsPtr->numExportPatterns ; i++) { - if (Tcl_StringMatch(nsCmdName, - ensemblePtr->nsPtr->exportArrayPtr[i])) { - hPtr = Tcl_CreateHashEntry(hash, nsCmdName, &isNew); - - /* - * Remember, hash entries have a full reference to the - * substituted part of the command (as a list) as their - * content! - */ - - if (isNew) { - Tcl_Obj *cmdObj, *cmdPrefixObj; - - TclNewObj(cmdObj); - Tcl_AppendStringsToObj(cmdObj, - ensemblePtr->nsPtr->fullName, - (ensemblePtr->nsPtr->parentPtr ? "::" : ""), - nsCmdName, NULL); - cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); - Tcl_SetHashValue(hPtr, (ClientData) cmdPrefixObj); - Tcl_IncrRefCount(cmdPrefixObj); - } - break; - } - } - } + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->callLiteral); + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewListObj( + iPtr->framePtr->objc, iPtr->framePtr->objv)); } - - if (hash->numEntries == 0) { - ensemblePtr->subcommandArrayPtr = NULL; - return; - } - - /* - * Create a sorted array of all subcommands in the ensemble; hash tables - * are all very well for a quick look for an exact match, but they can't - * determine things like whether a string is a prefix of another (not - * without lots of preparation anyway) and they're no good for when we're - * generating the error message either. - * - * We do this by filling an array with the names (we use the hash keys - * directly to save a copy, since any time we change the array we change - * the hash too, and vice versa) and running quicksort over the array. - */ - - ensemblePtr->subcommandArrayPtr = (char **) - ckalloc(sizeof(char *) * hash->numEntries); - - /* - * Fill array from both ends as this makes us less likely to end up with - * performance problems in qsort(), which is good. Note that doing this - * makes this code much more opaque, but the naive alternatve: - * - * for (hPtr=Tcl_FirstHashEntry(hash,&search),i=0 ; - * hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search),i++) { - * ensemblePtr->subcommandArrayPtr[i] = Tcl_GetHashKey(hash, &hPtr); - * } - * - * can produce long runs of precisely ordered table entries when the - * commands in the namespace are declared in a sorted fashion (an ordering - * some people like) and the hashing functions (or the command names - * themselves) are fairly unfortunate. By filling from both ends, it - * requires active malice (and probably a debugger) to get qsort() to have - * awful runtime behaviour. - */ - - i = 0; - j = hash->numEntries; - hPtr = Tcl_FirstHashEntry(hash, &search); - while (hPtr != NULL) { - ensemblePtr->subcommandArrayPtr[i++] = Tcl_GetHashKey(hash, hPtr); - hPtr = Tcl_NextHashEntry(&search); - if (hPtr == NULL) { - break; - } - ensemblePtr->subcommandArrayPtr[--j] = Tcl_GetHashKey(hash, hPtr); - hPtr = Tcl_NextHashEntry(&search); - } - if (hash->numEntries > 1) { - qsort(ensemblePtr->subcommandArrayPtr, (unsigned)hash->numEntries, - sizeof(char *), NsEnsembleStringOrder); - } -} - -/* - *---------------------------------------------------------------------- - * - * NsEnsembleStringOrder -- - * - * Helper function to compare two pointers to two strings for use with - * qsort(). - * - * Results: - * -1 if the first string is smaller, 1 if the second string is smaller, - * and 0 if they are equal. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -NsEnsembleStringOrder( - CONST void *strPtr1, - CONST void *strPtr2) -{ - return strcmp(*(CONST char **)strPtr1, *(CONST char **)strPtr2); } /* *---------------------------------------------------------------------- * - * FreeEnsembleCmdRep -- + * TclErrorStackResetIf -- * - * Destroys the internal representation of a Tcl_Obj that has been - * holding information about a command in an ensemble. + * The TIP 348 reset/no-bc part of TLCI, for specific use by + * TclCompileSyntaxError. * * Results: * None. * * Side effects: - * Memory is deallocated. If this held the last reference to a - * namespace's main structure, that main structure will also be - * destroyed. + * Reset errorstack if it needs be, and in that case remember the + * passed-in error message as inner context. * *---------------------------------------------------------------------- */ -static void -FreeEnsembleCmdRep( - Tcl_Obj *objPtr) +void +TclErrorStackResetIf( + Tcl_Interp *interp, + const char *msg, + int length) { - EnsembleCmdRep *ensembleCmd = (EnsembleCmdRep *) - objPtr->internalRep.otherValuePtr; + Interp *iPtr = (Interp *) interp; - Tcl_DecrRefCount(ensembleCmd->realPrefixObj); - ckfree(ensembleCmd->fullSubcmdName); - ensembleCmd->nsPtr->refCount--; - if ((ensembleCmd->nsPtr->refCount == 0) - && (ensembleCmd->nsPtr->flags & NS_DEAD)) { - NamespaceFree(ensembleCmd->nsPtr); + if (Tcl_IsShared(iPtr->errorStack)) { + Tcl_Obj *newObj; + + newObj = Tcl_DuplicateObj(iPtr->errorStack); + Tcl_DecrRefCount(iPtr->errorStack); + Tcl_IncrRefCount(newObj); + iPtr->errorStack = newObj; } - ckfree((char *)ensembleCmd); -} - -/* - *---------------------------------------------------------------------- - * - * DupEnsembleCmdRep -- - * - * Makes one Tcl_Obj into a copy of another that is a subcommand of an - * ensemble. - * - * Results: - * None. - * - * Side effects: - * Memory is allocated, and the namespace that the ensemble is built on - * top of gains another reference. - * - *---------------------------------------------------------------------- - */ + if (iPtr->resetErrorStack) { + int len; -static void -DupEnsembleCmdRep( - Tcl_Obj *objPtr, - Tcl_Obj *copyPtr) -{ - EnsembleCmdRep *ensembleCmd = (EnsembleCmdRep *) - objPtr->internalRep.otherValuePtr; - EnsembleCmdRep *ensembleCopy = (EnsembleCmdRep *) - ckalloc(sizeof(EnsembleCmdRep)); - int length = strlen(ensembleCmd->fullSubcmdName); - - copyPtr->typePtr = &ensembleCmdType; - copyPtr->internalRep.otherValuePtr = (void *) ensembleCopy; - ensembleCopy->nsPtr = ensembleCmd->nsPtr; - ensembleCopy->epoch = ensembleCmd->epoch; - ensembleCopy->token = ensembleCmd->token; - ensembleCopy->nsPtr->refCount++; - ensembleCopy->realPrefixObj = ensembleCmd->realPrefixObj; - Tcl_IncrRefCount(ensembleCopy->realPrefixObj); - ensembleCopy->fullSubcmdName = ckalloc((unsigned) length+1); - memcpy(ensembleCopy->fullSubcmdName, ensembleCmd->fullSubcmdName, - (unsigned) length+1); -} - -/* - *---------------------------------------------------------------------- - * - * StringOfEnsembleCmdRep -- - * - * Creates a string representation of a Tcl_Obj that holds a subcommand - * of an ensemble. - * - * Results: - * None. - * - * Side effects: - * The object gains a string (UTF-8) representation. - * - *---------------------------------------------------------------------- - */ + iPtr->resetErrorStack = 0; + Tcl_ListObjLength(interp, iPtr->errorStack, &len); -static void -StringOfEnsembleCmdRep( - Tcl_Obj *objPtr) -{ - EnsembleCmdRep *ensembleCmd = (EnsembleCmdRep *) - objPtr->internalRep.otherValuePtr; - int length = strlen(ensembleCmd->fullSubcmdName); + /* + * Reset while keeping the list intrep as much as possible. + */ - objPtr->length = length; - objPtr->bytes = ckalloc((unsigned) length+1); - memcpy(objPtr->bytes, ensembleCmd->fullSubcmdName, (unsigned) length+1); + Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL); + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->innerLiteral); + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, + Tcl_NewStringObj(msg, length)); + } } /* @@ -6638,86 +5042,39 @@ StringOfEnsembleCmdRep( * * Tcl_LogCommandInfo -- * - * This function is invoked after an error occurs in an interpreter. It - * adds information to iPtr->errorInfo field to describe the command that - * was being executed when the error occurred. + * This function is invoked after an error occurs in an interpreter. It + * adds information to iPtr->errorInfo/errorStack fields to describe the + * command that was being executed when the error occurred. * * Results: - * None. + * None. * * Side effects: - * Information about the command is added to errorInfo and the line - * number stored internally in the interpreter is set. + * Information about the command is added to errorInfo/errorStack and the + * line number stored internally in the interpreter is set. * *---------------------------------------------------------------------- */ void Tcl_LogCommandInfo( - Tcl_Interp *interp, /* Interpreter in which to log information. */ - CONST char *script, /* First character in script containing - * command (must be <= command). */ - CONST char *command, /* First character in command that generated - * the error. */ - int length) /* Number of bytes in command (-1 means use - * all bytes up to first null byte). */ + Tcl_Interp *interp, /* Interpreter in which to log information. */ + const char *script, /* First character in script containing + * command (must be <= command). */ + const char *command, /* First character in command that generated + * the error. */ + int length) /* Number of bytes in command (-1 means use + * all bytes up to first null byte). */ { - register CONST char *p; - Interp *iPtr = (Interp *) interp; - int overflow, limit = 150; - Var *varPtr, *arrayPtr; - - if (iPtr->flags & ERR_ALREADY_LOGGED) { - /* - * Someone else has already logged error information for this command; - * we shouldn't add anything more. - */ - - return; - } - - /* - * Compute the line number where the error occurred. - */ - - iPtr->errorLine = 1; - for (p = script; p != command; p++) { - if (*p == '\n') { - iPtr->errorLine++; - } - } - - overflow = (length > limit); - TclFormatToErrorInfo(interp, "\n %s\n\"%.*s%s\"", - ((iPtr->errorInfo == NULL) - ? "while executing" : "invoked from within"), - (overflow ? limit : length), command, (overflow ? "..." : "")); - - varPtr = TclObjLookupVar(interp, iPtr->eiVar, NULL, TCL_GLOBAL_ONLY, - NULL, 0, 0, &arrayPtr); - if ((varPtr == NULL) || (varPtr->tracePtr == NULL)) { - /* Should not happen */ - return; - } - if (varPtr->tracePtr->traceProc != EstablishErrorInfoTraces) { - /* - * The most recent trace set on ::errorInfo is not the one - * the core itself puts on last. This means some other code - * is tracing the variable, and the additional trace(s) might - * be write traces that expect the timing of writes to ::errorInfo - * that existed Tcl releases before 8.5. To satisfy that - * compatibility need, we write the current -errorinfo value - * to the ::errorInfo variable. - */ - Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, - iPtr->errorInfo, TCL_GLOBAL_ONLY); - } + TclLogCommandInfo(interp, script, command, length, NULL, NULL); } + /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 + * tab-width: 8 * End: */ |