diff options
author | dgp <dgp@users.sourceforge.net> | 2007-09-09 19:28:30 (GMT) |
---|---|---|
committer | dgp <dgp@users.sourceforge.net> | 2007-09-09 19:28:30 (GMT) |
commit | 1aec3f216c9ebfc5dd9d7e8146dc452e9f76b7ae (patch) | |
tree | dc288f72c9331c09129c27b60b55930645fd7521 | |
parent | c751a324c1745d7c554ff34f1a85d4d18c2dfa86 (diff) | |
download | tcl-1aec3f216c9ebfc5dd9d7e8146dc452e9f76b7ae.zip tcl-1aec3f216c9ebfc5dd9d7e8146dc452e9f76b7ae.tar.gz tcl-1aec3f216c9ebfc5dd9d7e8146dc452e9f76b7ae.tar.bz2 |
* generic/tclInt.h: Removed the "nsName" Tcl_ObjType from the
* generic/tclNamesp.c: registered set. Revised the management of
* generic/tclObj.c: the intrep of that Tcl_ObjType. Revised the
* tests/obj.test: TclGetNamespaceFromObj() routine to return
TCL_ERROR and write a consistent error message when a namespace is
not found. [Bug 1588842. Patch 1686862]
***POTENTIAL INCOMPATIBILITY***
For callers of Tcl_GetObjType() on the name "nsName".
* generic/tclExecute.c: Update TclGetNamespaceFromObj() callers.
* generic/tclProc.c:
* tests/apply.test: Updated tests to expect new consistent
* tests/namespace-old.test: error message when a namespace is not
* tests/namespace.test: found.
* tests/upvar.test:
-rw-r--r-- | ChangeLog | 19 | ||||
-rw-r--r-- | generic/tclExecute.c | 13 | ||||
-rw-r--r-- | generic/tclInt.h | 3 | ||||
-rw-r--r-- | generic/tclNamesp.c | 323 | ||||
-rw-r--r-- | generic/tclObj.c | 3 | ||||
-rw-r--r-- | generic/tclProc.c | 12 | ||||
-rw-r--r-- | tests/apply.test | 34 | ||||
-rw-r--r-- | tests/namespace-old.test | 16 | ||||
-rw-r--r-- | tests/namespace.test | 36 | ||||
-rw-r--r-- | tests/obj.test | 3 | ||||
-rw-r--r-- | tests/upvar.test | 8 |
11 files changed, 175 insertions, 295 deletions
@@ -1,5 +1,23 @@ 2007-09-09 Don Porter <dgp@users.sourceforge.net> + * generic/tclInt.h: Removed the "nsName" Tcl_ObjType from the + * generic/tclNamesp.c: registered set. Revised the management of + * generic/tclObj.c: the intrep of that Tcl_ObjType. Revised the + * tests/obj.test: TclGetNamespaceFromObj() routine to return + TCL_ERROR and write a consistent error message when a namespace is + not found. [Bug 1588842. Patch 1686862] + + ***POTENTIAL INCOMPATIBILITY*** + For callers of Tcl_GetObjType() on the name "nsName". + + * generic/tclExecute.c: Update TclGetNamespaceFromObj() callers. + * generic/tclProc.c: + + * tests/apply.test: Updated tests to expect new consistent + * tests/namespace-old.test: error message when a namespace is not + * tests/namespace.test: found. + * tests/upvar.test: + * generic/tclCompCmds.c: Use the new INST_REVERSE instruction * tests/mathop.test: to correct the compiled versions of math operator commands. [Bug 1724437]. @@ -2959,7 +2977,6 @@ * README: Bump version number to 8.5a6 * generic/tcl.h: - * library/init.tcl: * tools/tcl.wse.in: * unix/configure.in: * unix/tcl.spec: diff --git a/generic/tclExecute.c b/generic/tclExecute.c index e133c55..c9eabbe 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclExecute.c,v 1.331 2007/09/09 16:51:19 dgp Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.332 2007/09/09 19:28:30 dgp Exp $ */ #include "tclInt.h" @@ -3107,7 +3107,7 @@ TclExecuteByteCode( Tcl_Namespace *nsPtr, *savedNsPtr; result = TclGetNamespaceFromObj(interp, OBJ_UNDER_TOS, &nsPtr); - if ((result == TCL_OK) && nsPtr) { + if (result == TCL_OK) { /* * Locate the other variable. */ @@ -3119,18 +3119,9 @@ TclExecuteByteCode( /*createPart1*/ 1, /*createPart2*/ 1, &varPtr); iPtr->varFramePtr->nsPtr = (Namespace *) savedNsPtr; if (otherPtr) { - result = TCL_OK; goto doLinkVars; } } - if (!nsPtr) { - /* - * The namespace does not exist, leave an error message. - */ - - Tcl_SetObjResult(interp, Tcl_Format(NULL, - "namespace \"%s\" does not exist", 1,&OBJ_UNDER_TOS)); - } result = TCL_ERROR; goto checkForCatch; } diff --git a/generic/tclInt.h b/generic/tclInt.h index d0e49e1..6636f1e 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.333 2007/08/23 00:27:15 das Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.334 2007/09/09 19:28:31 dgp Exp $ */ #ifndef _TCLINT @@ -2283,7 +2283,6 @@ MODULE_SCOPE Tcl_ObjType tclDictType; MODULE_SCOPE Tcl_ObjType tclProcBodyType; MODULE_SCOPE Tcl_ObjType tclStringType; MODULE_SCOPE Tcl_ObjType tclArraySearchType; -MODULE_SCOPE Tcl_ObjType tclNsNameType; MODULE_SCOPE Tcl_ObjType tclEnsembleCmdType; #ifndef NO_WIDE_TYPE MODULE_SCOPE Tcl_ObjType tclWideIntType; diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index d111f31..41b93d0 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -13,6 +13,7 @@ * 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 @@ -22,7 +23,7 @@ * 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.148 2007/08/03 13:51:40 dkf Exp $ + * RCS: @(#) $Id: tclNamesp.c,v 1.149 2007/09/09 19:28:31 dgp Exp $ */ #include "tclInt.h" @@ -54,15 +55,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). NULL if the name - * is fully qualified.*/ + 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 @@ -167,6 +165,8 @@ static char * EstablishErrorInfoTraces(ClientData clientData, 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[]); static int NamespaceChildrenCmd(ClientData dummy, @@ -210,7 +210,6 @@ static int NamespaceUnknownCmd(ClientData dummy, static int NamespaceWhichCmd(ClientData dummy, Tcl_Interp *interp, 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); @@ -232,11 +231,11 @@ static void UnlinkNsPath(Namespace *nsPtr); * the object. */ -Tcl_ObjType tclNsNameType = { +static Tcl_ObjType nsNameType = { "nsName", /* the type's name */ FreeNsNameInternalRep, /* freeIntRepProc */ DupNsNameInternalRep, /* dupIntRepProc */ - UpdateStringOfNsName, /* updateStringProc */ + NULL, /* updateStringProc */ SetNsNameFromAny /* setFromAnyProc */ }; @@ -381,6 +380,15 @@ Tcl_PushCallFrame( 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*/ @@ -2411,7 +2419,7 @@ 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); @@ -2432,7 +2440,7 @@ 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); @@ -2450,7 +2458,7 @@ 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); @@ -2636,18 +2644,15 @@ TclResetShadowedCmdRefs( * 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. - * *---------------------------------------------------------------------- */ @@ -2658,50 +2663,49 @@ TclGetNamespaceFromObj( * namespace. */ Tcl_Namespace **nsPtrPtr) /* Result namespace pointer goes here. */ { - ResolvedNsName *resPtr; - Namespace *nsPtr; - int result = TCL_OK; - - /* - * Get the internal representation, converting to a namespace type if - * needed. The internal representation is a ResolvedNsName that points to - * the actual namespace. - * - * Check the context namespace of the resolved symbol to make sure that it - * is fresh. Note that we verify that the namespace id of the context - * namespace is the same as the one we cached; this insures that the - * namespace wasn't deleted and a new one created at the same address. - * Note that fully qualified names have a NULL refNsPtr, these checks - * needn't be made. - * - * If any check fails, then force another conversion to the command type, - * to discard the old rep and create a new one. - */ - - resPtr = (ResolvedNsName *) objPtr->internalRep.twoPtrValue.ptr1; - if ((objPtr->typePtr != &tclNsNameType) - || (resPtr == NULL) - || (resPtr->refNsPtr && - (resPtr->refNsPtr != (Namespace *) TclGetCurrentNamespace(interp))) - || (nsPtr = resPtr->nsPtr, nsPtr->flags & NS_DEAD) - || (interp != nsPtr->interp) - || (resPtr->nsId != nsPtr->nsId)) { - - result = tclNsNameType.setFromAnyProc(interp, objPtr); - - resPtr = (ResolvedNsName *) objPtr->internalRep.twoPtrValue.ptr1; - if ((result == TCL_OK) && resPtr) { - nsPtr = resPtr->nsPtr; - if (nsPtr && (nsPtr->flags & NS_DEAD)) { - nsPtr = NULL; - } + if (GetNamespaceFromObj(interp, objPtr, nsPtrPtr) == TCL_ERROR) { + const char *name = Tcl_GetString(objPtr); + if ((name[0] == ':') && (name[1] == ':')) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "namespace \"%s\" not found", name)); } else { - nsPtr = NULL; + /* Get the current namespace name */ + NamespaceCurrentCmd(NULL, interp, 2, NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "namespace \"%s\" not found in \"%s\"", name, + Tcl_GetStringResult(interp))); } + return TCL_ERROR; } + return TCL_OK; +} +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; - *nsPtrPtr = (Tcl_Namespace *) nsPtr; - return result; + if (objPtr->typePtr == &nsNameType) { + /* Check that the ResolvedNsName is still valid. */ + resNamePtr = (ResolvedNsName *) objPtr->internalRep.twoPtrValue.ptr1; + nsPtr = resNamePtr->nsPtr; + if (!(nsPtr->flags & NS_DYING) + && ((resNamePtr->refNsPtr == NULL) || (resNamePtr->refNsPtr + == (Namespace *) Tcl_GetCurrentNamespace(interp)))) { + *nsPtrPtr = (Tcl_Namespace *) nsPtr; + return TCL_OK; + } + } + if (SetNsNameFromAny(interp, objPtr) == TCL_OK) { + resNamePtr = (ResolvedNsName *) objPtr->internalRep.twoPtrValue.ptr1; + *nsPtrPtr = (Tcl_Namespace *) resNamePtr->nsPtr; + return TCL_OK; + } + return TCL_ERROR; } /* @@ -2889,12 +2893,6 @@ NamespaceChildrenCmd( 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); - return TCL_ERROR; - } nsPtr = (Namespace *) namespacePtr; } else { Tcl_WrongNumArgs(interp, 2, objv, "?name? ?pattern?"); @@ -3229,16 +3227,13 @@ NamespaceEvalCmd( * namespace object along the way. */ - result = TclGetNamespaceFromObj(interp, objv[2], &namespacePtr); - if (result != TCL_OK) { - return result; - } + result = GetNamespaceFromObj(interp, objv[2], &namespacePtr); /* * If the namespace wasn't found, try to create it. */ - if (namespacePtr == NULL) { + if (result == TCL_ERROR) { char *name = TclGetString(objv[2]); namespacePtr = Tcl_CreateNamespace(interp, name, (ClientData) NULL, NULL); @@ -3341,15 +3336,8 @@ NamespaceExistsCmd( return TCL_ERROR; } - /* - * Check whether the given namespace exists - */ - - if (TclGetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) { - return TCL_ERROR; - } - - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(namespacePtr != NULL)); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj( + GetNamespaceFromObj(interp, objv[2], &namespacePtr) == TCL_OK)); return TCL_OK; } @@ -3682,11 +3670,6 @@ NamespaceInscopeCmd( if (result != TCL_OK) { return result; } - if (namespacePtr == NULL) { - Tcl_AppendResult(interp, "unknown namespace \"", TclGetString(objv[2]), - "\" in inscope namespace command", NULL); - return TCL_ERROR; - } /* * Make the specified namespace the current namespace. @@ -3856,12 +3839,6 @@ NamespaceParentCmd( if (result != TCL_OK) { return result; } - if (nsPtr == NULL) { - Tcl_AppendResult(interp, "unknown namespace \"", - TclGetString(objv[2]), - "\" in namespace parent command", NULL); - return TCL_ERROR; - } } else { Tcl_WrongNumArgs(interp, 2, objv, "?name?"); return TCL_ERROR; @@ -3957,11 +3934,6 @@ NamespacePathCmd( &namespaceList[i]) != TCL_OK) { goto badNamespace; } - if (namespaceList[i] == NULL) { - Tcl_AppendResult(interp, "unknown namespace \"", - TclGetString(nsObjv[i]), "\"", NULL); - goto badNamespace; - } } } @@ -4459,14 +4431,6 @@ NamespaceUpvarCmd( if (result != TCL_OK) { return TCL_ERROR; } - if (nsPtr == NULL) { - /* - * The namespace does not exist, leave an error message. - */ - Tcl_SetObjResult(interp, Tcl_Format(NULL, - "namespace \"%s\" does not exist", 1, objv+2)); - return TCL_ERROR; - } objc -= 3; objv += 3; @@ -4612,23 +4576,21 @@ FreeNsNameInternalRep( * references, free it up. */ - if (resNamePtr != NULL) { - resNamePtr->refCount--; - if (resNamePtr->refCount == 0) { + 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. - */ + /* + * Decrement the reference count for the cached namespace. If the + * namespace is dead, and there are no more references to it, free + * it. + */ - nsPtr = resNamePtr->nsPtr; - nsPtr->refCount--; - if ((nsPtr->refCount == 0) && (nsPtr->flags & NS_DEAD)) { - NamespaceFree(nsPtr); - } - ckfree((char *) resNamePtr); + nsPtr = resNamePtr->nsPtr; + nsPtr->refCount--; + if ((nsPtr->refCount == 0) && (nsPtr->flags & NS_DEAD)) { + NamespaceFree(nsPtr); } + ckfree((char *) resNamePtr); } } @@ -4660,10 +4622,8 @@ DupNsNameInternalRep( srcPtr->internalRep.twoPtrValue.ptr1; copyPtr->internalRep.twoPtrValue.ptr1 = (void *) resNamePtr; - if (resNamePtr != NULL) { - resNamePtr->refCount++; - } - copyPtr->typePtr = &tclNsNameType; + resNamePtr->refCount++; + copyPtr->typePtr = &nsNameType; } /* @@ -4695,118 +4655,47 @@ SetNsNameFromAny( * NULL. */ register Tcl_Obj *objPtr) /* The object to convert. */ { - char *name; const char *dummy; Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr; register ResolvedNsName *resNamePtr; + const char *name = TclGetString(objPtr); - /* - * 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. - */ - - name = TclGetString(objPtr); 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. - * - * Free the old internalRep before setting the new one. Do this after - * getting the string rep to allow the conversion code (in particular, - * Tcl_GetStringFromObj) to use that old internalRep. */ - if (nsPtr) { + if ((nsPtr != NULL) && !(nsPtr->flags & NS_DYING)) { nsPtr->refCount++; - resNamePtr = (ResolvedNsName *) objPtr->internalRep.twoPtrValue.ptr1; - if ((objPtr->typePtr == &tclNsNameType) - && resNamePtr && (resNamePtr->refCount == 1)) { - /* - * Reuse the old ResolvedNsName struct instead of freeing it - */ - - Namespace *oldNsPtr = resNamePtr->nsPtr; - if ((--oldNsPtr->refCount == 0) && (oldNsPtr->flags & NS_DEAD)) { - NamespaceFree(oldNsPtr); - } - } else { - TclFreeIntRep(objPtr); - resNamePtr = (ResolvedNsName *) ckalloc(sizeof(ResolvedNsName)); - resNamePtr->refCount = 1; - objPtr->internalRep.twoPtrValue.ptr1 = (void *) resNamePtr; - objPtr->typePtr = &tclNsNameType; - } + resNamePtr = (ResolvedNsName *) ckalloc(sizeof(ResolvedNsName)); resNamePtr->nsPtr = nsPtr; - resNamePtr->nsId = nsPtr->nsId; - if ((*name++ == ':') && (*name == ':')) { + if ((name[0] == ':') && (name[1] == ':')) { resNamePtr->refNsPtr = NULL; } else { resNamePtr->refNsPtr = - (Namespace *) TclGetCurrentNamespace(interp); + (Namespace *) Tcl_GetCurrentNamespace(interp); } - } else { + resNamePtr->refCount = 1; TclFreeIntRep(objPtr); - objPtr->internalRep.twoPtrValue.ptr1 = (void *) NULL; - objPtr->typePtr = &tclNsNameType; - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * UpdateStringOfNsName -- - * - * 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. - * - * Results: - * None. - * - * Side effects: - * The object's string is set to a copy of the fully qualified namespace - * name. - * - *---------------------------------------------------------------------- - */ - -static void -UpdateStringOfNsName( - register Tcl_Obj *objPtr) /* nsName object with string rep to update. */ -{ - ResolvedNsName *resNamePtr = - (ResolvedNsName *) objPtr->internalRep.otherValuePtr; - char *name = ""; - int length = 0; - - if ((resNamePtr != NULL) - && (resNamePtr->nsId == resNamePtr->nsPtr->nsId)) { - register Namespace *nsPtr = resNamePtr->nsPtr; - - if (nsPtr != NULL && !(nsPtr->flags & NS_DEAD)) { - name = nsPtr->fullName; - length = strlen(name); + objPtr->internalRep.twoPtrValue.ptr1 = (void *) resNamePtr; + objPtr->typePtr = &nsNameType; + return TCL_OK; + } else { + if (objPtr->typePtr == &nsNameType) { + /* + * 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. + */ + TclFreeIntRep(objPtr); + objPtr->typePtr = NULL; } + return TCL_ERROR; } - - /* - * The following sets the string rep to an empty string on the heap if the - * internal rep is NULL. - */ - - if (length == 0) { - objPtr->bytes = tclEmptyStringRep; - } else { - objPtr->bytes = (char *) ckalloc((unsigned) (length + 1)); - memcpy(objPtr->bytes, name, (unsigned) length); - objPtr->bytes[length] = '\0'; - } - objPtr->length = length; } /* @@ -4861,7 +4750,7 @@ NamespaceEnsembleCmd( int index; nsPtr = (Namespace *) TclGetCurrentNamespace(interp); - if (nsPtr == NULL || nsPtr->flags & NS_DEAD) { + if (nsPtr == NULL || nsPtr->flags & NS_DYING) { if (!Tcl_InterpDeleted(interp)) { Tcl_AppendResult(interp, "tried to manipulate ensemble of deleted namespace", NULL); @@ -5989,7 +5878,7 @@ NsEnsembleImplementationCmd( } restartEnsembleParse: - if (!(ensemblePtr->nsPtr->flags & NS_DEAD)) { + if (!(ensemblePtr->nsPtr->flags & NS_DYING)) { if (ensemblePtr->epoch == ensemblePtr->nsPtr->exportLookupEpoch) { /* * Table of subcommands is still valid; therefore there might be a diff --git a/generic/tclObj.c b/generic/tclObj.c index 12ea2b8..574947b 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclObj.c,v 1.133 2007/09/03 01:36:54 das Exp $ + * RCS: @(#) $Id: tclObj.c,v 1.134 2007/09/09 19:28:31 dgp Exp $ */ #include "tclInt.h" @@ -360,7 +360,6 @@ TclInitObjSubsystem(void) Tcl_RegisterObjType(&tclDictType); Tcl_RegisterObjType(&tclByteCodeType); Tcl_RegisterObjType(&tclArraySearchType); - Tcl_RegisterObjType(&tclNsNameType); Tcl_RegisterObjType(&tclCmdNameType); Tcl_RegisterObjType(&tclRegexpType); Tcl_RegisterObjType(&tclProcBodyType); diff --git a/generic/tclProc.c b/generic/tclProc.c index c09b7df..cd85e73 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclProc.c,v 1.132 2007/09/07 18:01:36 msofer Exp $ + * RCS: @(#) $Id: tclProc.c,v 1.133 2007/09/09 19:28:31 dgp Exp $ */ #include "tclInt.h" @@ -2549,7 +2549,7 @@ Tcl_ApplyObjCmd( { Interp *iPtr = (Interp *) interp; Proc *procPtr = NULL; - Tcl_Obj *lambdaPtr, *nsObjPtr, *errPtr; + Tcl_Obj *lambdaPtr, *nsObjPtr; int result, isRootEnsemble; Command cmd; Tcl_Namespace *nsPtr; @@ -2627,14 +2627,6 @@ Tcl_ApplyObjCmd( return result; } - if (nsPtr == NULL) { - TclNewLiteralStringObj(errPtr, "cannot find namespace \""); - Tcl_AppendObjToObj(errPtr, nsObjPtr); - Tcl_AppendToObj(errPtr, "\"", -1); - Tcl_SetObjResult(interp, errPtr); - return TCL_ERROR; - } - cmd.nsPtr = (Namespace *) nsPtr; isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL); diff --git a/tests/apply.test b/tests/apply.test index 93c77a2..894aad3 100644 --- a/tests/apply.test +++ b/tests/apply.test @@ -12,10 +12,10 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: apply.test,v 1.10 2007/03/29 19:22:08 msofer Exp $ +# RCS: @(#) $Id: apply.test,v 1.11 2007/09/09 19:28:31 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest + package require tcltest 2.2 namespace import -force ::tcltest::* } @@ -79,32 +79,26 @@ test apply-2.5 {malformed lambda} { # Tests for runtime errors in the lambda expression -test apply-3.1 {non-existing namespace} { - set lambda [list x {set x 1} ::NONEXIST::FOR::SURE] - set res [catch {apply $lambda x} msg] - list $res $msg -} {1 {cannot find namespace "::NONEXIST::FOR::SURE"}} -test apply-3.2 {non-existing namespace} { +test apply-3.1 {non-existing namespace} -body { + apply [list x {set x 1} ::NONEXIST::FOR::SURE] x +} -returnCodes error -result {namespace "::NONEXIST::FOR::SURE" not found} +test apply-3.2 {non-existing namespace} -body { namespace eval ::NONEXIST::FOR::SURE {} set lambda [list x {set x 1} ::NONEXIST::FOR::SURE] apply $lambda x namespace delete ::NONEXIST - set res [catch {apply $lambda x} msg] - list $res $msg -} {1 {cannot find namespace "::NONEXIST::FOR::SURE"}} -test apply-3.3 {non-existing namespace} { - set lambda [list x {set x 1} NONEXIST::FOR::SURE] - set res [catch {apply $lambda x} msg] - list $res $msg -} {1 {cannot find namespace "::NONEXIST::FOR::SURE"}} -test apply-3.4 {non-existing namespace} { + apply $lambda x +} -returnCodes error -result {namespace "::NONEXIST::FOR::SURE" not found} +test apply-3.3 {non-existing namespace} -body { + apply [list x {set x 1} NONEXIST::FOR::SURE] x +} -returnCodes error -result {namespace "::NONEXIST::FOR::SURE" not found} +test apply-3.4 {non-existing namespace} -body { namespace eval ::NONEXIST::FOR::SURE {} set lambda [list x {set x 1} NONEXIST::FOR::SURE] apply $lambda x namespace delete ::NONEXIST - set res [catch {apply $lambda x} msg] - list $res $msg -} {1 {cannot find namespace "::NONEXIST::FOR::SURE"}} + apply $lambda x +} -returnCodes error -result {namespace "::NONEXIST::FOR::SURE" not found} test apply-4.1 {error in arguments to lambda expression} { set lambda [list x {set x 1}] diff --git a/tests/namespace-old.test b/tests/namespace-old.test index 7bfea61..1b0757e 100644 --- a/tests/namespace-old.test +++ b/tests/namespace-old.test @@ -14,10 +14,10 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: namespace-old.test,v 1.11 2006/11/23 15:35:31 dkf Exp $ +# RCS: @(#) $Id: namespace-old.test,v 1.12 2007/09/09 19:28:31 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest + package require tcltest 2.2 namespace import -force ::tcltest::* } @@ -336,9 +336,9 @@ test namespace-old-5.9 {usage for "namespace children"} { list [catch {namespace children test_ns_hier1 y z} msg] $msg } {1 {wrong # args: should be "namespace children ?name? ?pattern?"}} -test namespace-old-5.10 {command "namespace children" must get valid namespace} { - list [catch {namespace children xyzzy} msg] $msg -} {1 {unknown namespace "xyzzy" in namespace children command}} +test namespace-old-5.10 {command "namespace children" must get valid namespace} -body { + namespace children xyzzy +} -returnCodes error -result {namespace "xyzzy" not found in "::"} test namespace-old-5.11 {querying namespace children} { lsort [namespace children :: test_ns_hier*] @@ -372,9 +372,9 @@ test namespace-old-5.18 {usage for "namespace parent"} { list [catch {namespace parent x y} msg] $msg } {1 {wrong # args: should be "namespace parent ?name?"}} -test namespace-old-5.19 {command "namespace parent" must get valid namespace} { - list [catch {namespace parent xyzzy} msg] $msg -} {1 {unknown namespace "xyzzy" in namespace parent command}} +test namespace-old-5.19 {command "namespace parent" must get valid namespace} -body { + namespace parent xyzzy +} -returnCodes error -result {namespace "xyzzy" not found in "::"} test namespace-old-5.20 {querying namespace parent} { list [namespace eval :: {namespace parent}] \ diff --git a/tests/namespace.test b/tests/namespace.test index 3228d72..3ef1e35 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: namespace.test,v 1.67 2007/06/12 12:34:04 dkf Exp $ +# RCS: @(#) $Id: namespace.test,v 1.68 2007/09/09 19:28:31 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -232,7 +232,7 @@ test namespace-8.3 {TclTeardownNamespace, delete child namespaces} { [namespace children test_ns_1] \ [catch {namespace children test_ns_1::test_ns_2} msg] $msg \ [info commands test_ns_1::test_ns_2::test_ns_3a::*] -} {::test_ns_1::test_ns_2 {} {} 1 {unknown namespace "test_ns_1::test_ns_2" in namespace children command} {}} +} {::test_ns_1::test_ns_2 {} {} 1 {namespace "test_ns_1::test_ns_2" not found in "::"} {}} test namespace-8.4 {TclTeardownNamespace, cmds imported from deleted ns go away} { catch {namespace delete {*}[namespace children :: test_ns_*]} namespace eval test_ns_export { @@ -572,7 +572,7 @@ test namespace-14.2 {TclGetNamespaceForQualName, invalid absolute names} { list [catch {set ::test_ns_777::v} msg] $msg \ [catch {namespace children test_ns_777} msg] $msg } -} {1 {can't read "::test_ns_777::v": no such variable} 1 {unknown namespace "test_ns_777" in namespace children command}} +} {1 {can't read "::test_ns_777::v": no such variable} 1 {namespace "test_ns_777" not found in "::test_ns_1"}} test namespace-14.3 {TclGetNamespaceForQualName, relative names} { namespace eval test_ns_1 { list $v $test_ns_2::v @@ -586,7 +586,7 @@ test namespace-14.4 {TclGetNamespaceForQualName, relative ns names looked up onl list [namespace children test_ns_2] \ [catch {namespace children test_ns_1} msg] $msg } -} {::test_ns_1::test_ns_2::foo 1 {unknown namespace "test_ns_1" in namespace children command}} +} {::test_ns_1::test_ns_2::foo 1 {namespace "test_ns_1" not found in "::test_ns_1"}} test namespace-14.5 {TclGetNamespaceForQualName, relative ns names looked up only in current ns} { namespace eval ::test_ns_2 { namespace eval bar {} @@ -604,7 +604,7 @@ test namespace-14.6 {TclGetNamespaceForQualName, relative ns names looked up onl list [namespace children test_ns_2] \ [catch {namespace children test_ns_1} msg] $msg } -} {::test_ns_1::test_ns_2::foo 1 {unknown namespace "test_ns_1" in namespace children command}} +} {::test_ns_1::test_ns_2::foo 1 {namespace "test_ns_1" not found in "::test_ns_1"}} test namespace-14.7 {TclGetNamespaceForQualName, ignore extra :s if ns} { namespace children test_ns_1::: } {::test_ns_1::test_ns_2} @@ -867,11 +867,11 @@ test namespace-19.2 {GetNamespaceFromObj, relative name found} { namespace children test_ns_2 } } {} -test namespace-19.3 {GetNamespaceFromObj, name not found} { +test namespace-19.3 {GetNamespaceFromObj, name not found} -body { namespace eval test_ns_1 { - list [catch {namespace children test_ns_99} msg] $msg + namespace children test_ns_99 } -} {1 {unknown namespace "test_ns_99" in namespace children command}} +} -returnCodes error -result {namespace "test_ns_99" not found in "::test_ns_1"} test namespace-19.4 {GetNamespaceFromObj, invalidation of cached ns refs} { namespace eval test_ns_1 { proc foo {} { @@ -1148,9 +1148,9 @@ test namespace-29.1 {NamespaceInscopeCmd, bad args} { test namespace-29.2 {NamespaceInscopeCmd, bad args} { list [catch {namespace inscope ::} msg] $msg } {1 {wrong # args: should be "namespace inscope name arg ?arg...?"}} -test namespace-29.3 {NamespaceInscopeCmd, specified ns must exist} { - list [catch {namespace inscope test_ns_1 {set v}} msg] $msg -} {1 {unknown namespace "test_ns_1" in inscope namespace command}} +test namespace-29.3 {NamespaceInscopeCmd, specified ns must exist} -body { + namespace inscope test_ns_1 {set v} +} -returnCodes error -result {namespace "test_ns_1" not found in "::"} test namespace-29.4 {NamespaceInscopeCmd, simple case} { namespace eval test_ns_1 { variable v 747 @@ -1220,9 +1220,9 @@ test namespace-31.3 {NamespaceParentCmd, namespace specified} { [namespace parent test_ns_1::test_ns_2] \ [namespace eval test_ns_1::test_ns_2::test_ns_3 {namespace parent ::test_ns_1::test_ns_2}] } {{} ::test_ns_1 ::test_ns_1} -test namespace-31.4 {NamespaceParentCmd, bad namespace specified} { - list [catch {namespace parent test_ns_1::test_ns_foo} msg] $msg -} {1 {unknown namespace "test_ns_1::test_ns_foo" in namespace parent command}} +test namespace-31.4 {NamespaceParentCmd, bad namespace specified} -body { + namespace parent test_ns_1::test_ns_foo +} -returnCodes error -result {namespace "test_ns_1::test_ns_foo" not found in "::"} test namespace-32.1 {NamespaceQualifiersCmd, bad args} { catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -1368,11 +1368,11 @@ test namespace-37.1 {SetNsNameFromAny, ns name found} { namespace children ::test_ns_1 } } {::test_ns_1::test_ns_2} -test namespace-37.2 {SetNsNameFromAny, ns name not found} { +test namespace-37.2 {SetNsNameFromAny, ns name not found} -body { namespace eval test_ns_1 { - list [catch {namespace children ::test_ns_1::test_ns_foo} msg] $msg + namespace children ::test_ns_1::test_ns_foo } -} {1 {unknown namespace "::test_ns_1::test_ns_foo" in namespace children command}} +} -returnCodes error -result {namespace "::test_ns_1::test_ns_foo" not found} test namespace-38.1 {UpdateStringOfNsName} { catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -2334,7 +2334,7 @@ test namespace-51.10 {name resolution path control} -body { namespace eval ::test_ns_1 { namespace path does::not::exist } -} -returnCodes error -result {unknown namespace "does::not::exist"} -cleanup { +} -returnCodes error -result {namespace "does::not::exist" not found in "::test_ns_1"} -cleanup { catch {namespace delete ::test_ns_1} } test namespace-51.11 {name resolution path control} -body { diff --git a/tests/obj.test b/tests/obj.test index 51c9e43..949128d 100644 --- a/tests/obj.test +++ b/tests/obj.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: obj.test,v 1.19 2005/10/08 14:42:54 dgp Exp $ +# RCS: @(#) $Id: obj.test,v 1.20 2007/09/09 19:28:31 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -31,7 +31,6 @@ test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} tes cmdName dict end-offset - nsName regexp string } { diff --git a/tests/upvar.test b/tests/upvar.test index 59d55a9..8cb9f36 100644 --- a/tests/upvar.test +++ b/tests/upvar.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: upvar.test,v 1.14 2006/11/03 00:34:53 hobbs Exp $ +# RCS: @(#) $Id: upvar.test,v 1.15 2007/09/09 19:28:32 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -455,7 +455,7 @@ test upvar-NS-1.3 {nsupvar links to correct variable} \ set w } } \ - -result {namespace "test_ns_0" does not exist} \ + -result {namespace "test_ns_0" not found in "::test_ns_1"} \ -returnCodes error \ -cleanup {namespace delete test_ns_1} @@ -469,7 +469,7 @@ test upvar-NS-1.4 {nsupvar links to correct variable} \ return [a] } } \ - -result {namespace "test_ns_0" does not exist} \ + -result {namespace "test_ns_0" not found in "::test_ns_1"} \ -returnCodes error \ -cleanup {namespace delete test_ns_1} @@ -540,7 +540,7 @@ test upvar-NS-1.9 {nsupvar links to correct variable} \ return [a] } } \ - -result {namespace "test_ns_0" does not exist} \ + -result {namespace "test_ns_0" not found in "::test_ns_1"} \ -returnCodes error \ -cleanup {namespace delete test_ns_1} |