From 2555e0d7e6f980833f0369e83b81b0c37050c3f5 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Sun, 10 Dec 2017 21:45:26 +0000 Subject: Streamline TclOO object cleanup routines. --- generic/tclBasic.c | 2 + generic/tclOO.c | 619 ++++++++++++++++++---------------------------- generic/tclOOBasic.c | 5 - generic/tclOOCall.c | 4 +- generic/tclOODefineCmds.c | 62 ++++- generic/tclOOInt.h | 46 ++-- tests/oo.test | 13 +- 7 files changed, 326 insertions(+), 425 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index eceea31..a23100e 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -3152,6 +3152,8 @@ Tcl_DeleteCommandFromToken( */ cmdPtr->nsPtr->refCount++; + + cmdPtr->nsPtr->refCount++; if (cmdPtr->tracePtr != NULL) { CommandTrace *tracePtr; CallCommandTraces(iPtr,cmdPtr,NULL,NULL,TCL_TRACE_DELETE); diff --git a/generic/tclOO.c b/generic/tclOO.c index 84380e0..ae1ae3f 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -60,8 +60,6 @@ static const struct { static Class * AllocClass(Tcl_Interp *interp, Object *useThisObj); static Object * AllocObject(Tcl_Interp *interp, const char *nameStr, Namespace *nsPtr, const char *nsNameStr); -static void ClearMixins(Class *clsPtr); -static void ClearSuperclasses(Class *clsPtr); static int CloneClassMethod(Tcl_Interp *interp, Class *clsPtr, Method *mPtr, Tcl_Obj *namePtr, Method **newMPtrPtr); @@ -73,6 +71,7 @@ static void DeletedHelpersNamespace(ClientData clientData); static Tcl_NRPostProc FinalizeAlloc; static Tcl_NRPostProc FinalizeNext; static Tcl_NRPostProc FinalizeObjectCall; +static void initClassPath(Tcl_Interp * interp, Class *clsPtr); static int InitFoundation(Tcl_Interp *interp); static void KillFoundation(ClientData clientData, Tcl_Interp *interp); @@ -82,6 +81,7 @@ static void ObjectRenamedTrace(ClientData clientData, Tcl_Interp *interp, const char *oldName, const char *newName, int flags); static void ReleaseClassContents(Tcl_Interp *interp,Object *oPtr); +static void DeleteDescendants(Tcl_Interp *interp,Object *oPtr); static inline void SquelchCachedName(Object *oPtr); static int PublicObjectCmd(ClientData clientData, @@ -96,6 +96,8 @@ static int PrivateObjectCmd(ClientData clientData, static int PrivateNRObjectCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); +static void RemoveClass(Class ** list, int num, int idx); +static void RemoveObject(Object ** list, int num, int idx); /* * Methods in the oo::object and oo::class classes. First, we define a helper @@ -228,10 +230,14 @@ MODULE_SCOPE const TclOOStubs tclOOStubs; * ROOT_CLASS respectively. */ -#define Deleted(oPtr) (((Object *)(oPtr))->command == NULL) +#define Deleted(oPtr) ((oPtr)->flags & OBJECT_DELETED) #define IsRootObject(ocPtr) ((ocPtr)->flags & ROOT_OBJECT) #define IsRootClass(ocPtr) ((ocPtr)->flags & ROOT_CLASS) #define IsRoot(ocPtr) ((ocPtr)->flags & (ROOT_OBJECT|ROOT_CLASS)) + +#define RemoveItem(type, lst, i) \ + Remove ## type ((lst).list, (lst).num, i); \ + (lst).num-- /* * ---------------------------------------------------------------------- @@ -313,6 +319,10 @@ InitFoundation( Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData)); Foundation *fPtr = ckalloc(sizeof(Foundation)); Tcl_Obj *namePtr, *argsPtr, *bodyPtr; + + Class fakeCls; + Object fakeObject; + Tcl_DString buffer; Command *cmdPtr; int i; @@ -379,24 +389,43 @@ InitFoundation( * spliced manually. */ + /* Stand up a phony class for bootstrapping. */ + fPtr->objectCls = &fakeCls; + /* referenced in AllocClass to increment the refCount. */ + fakeCls.thisPtr = &fakeObject; + fPtr->objectCls = AllocClass(interp, AllocObject(interp, "object", (Namespace *)fPtr->ooNs, NULL)); fPtr->classCls = AllocClass(interp, AllocObject(interp, "class", (Namespace *)fPtr->ooNs, NULL)); + + /* Rewire bootstrapped objects. */ fPtr->objectCls->thisPtr->selfCls = fPtr->classCls; + fPtr->classCls->thisPtr->selfCls = fPtr->classCls; + + AddRef(fPtr->objectCls->thisPtr); + AddRef(fPtr->classCls->thisPtr); + AddRef(fPtr->classCls->thisPtr->selfCls->thisPtr); + AddRef(fPtr->objectCls->thisPtr->selfCls->thisPtr); + + /* special initialization for the primordial objects */ fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT; fPtr->objectCls->flags |= ROOT_OBJECT; + + /* This is why it is unnecessary in this routine to make up for the + * incremented reference count of fPtr->objectCls that was sallwed by + * fakeObject. */ fPtr->objectCls->superclasses.num = 0; ckfree(fPtr->objectCls->superclasses.list); fPtr->objectCls->superclasses.list = NULL; - fPtr->classCls->thisPtr->selfCls = fPtr->classCls; + fPtr->classCls->thisPtr->flags |= ROOT_CLASS; fPtr->classCls->flags |= ROOT_CLASS; + + /* Standard initialization for new Objects */ TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls); TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls); TclOOAddToSubclasses(fPtr->classCls, fPtr->objectCls); - AddRef(fPtr->objectCls->thisPtr); - AddRef(fPtr->objectCls); /* * Basic method declarations for the core classes. @@ -522,8 +551,6 @@ KillFoundation( { Foundation *fPtr = GetFoundation(interp); - DelRef(fPtr->objectCls->thisPtr); - DelRef(fPtr->objectCls); TclDecrRefCount(fPtr->unknownMethodNameObj); TclDecrRefCount(fPtr->constructorName); TclDecrRefCount(fPtr->destructorName); @@ -538,8 +565,11 @@ KillFoundation( * AllocObject -- * * Allocate an object of basic type. Does not splice the object into its - * class's instance list. The caller must set the classPtr on the object, - * either to a class or to NULL. + * class's instance list. The caller must set the classPtr on the object + * to either a class or NULL, call TclOOAddToInstances to add the object + * to the class's instance list, and if the object itself is a class, use + * call TclOOAddToSubclasses() to add it to the right class's list of + * subclasses. * * ---------------------------------------------------------------------- */ @@ -564,7 +594,7 @@ AllocObject( Object *oPtr; Command *cmdPtr; CommandTrace *tracePtr; - int creationEpoch, ignored; + int creationEpoch; oPtr = ckalloc(sizeof(Object)); memset(oPtr, 0, sizeof(Object)); @@ -641,9 +671,15 @@ AllocObject( */ oPtr->fPtr = fPtr; - oPtr->selfCls = fPtr->objectCls; oPtr->creationEpoch = creationEpoch; - oPtr->refCount = 1; + + /* + * An object starts life with a refCount of 2 to mark the two stages of + * destruction it occur: A call to ObjectRenamedTrace(), and a call to + * ObjectNamespaceDeleted(). + */ + oPtr->refCount = 2; + oPtr->flags = USE_CLASS_CACHE; /* @@ -655,6 +691,10 @@ AllocObject( if (!nameStr) { nameStr = oPtr->namespacePtr->name; nsPtr = (Namespace *)oPtr->namespacePtr; + if (nsPtr->parentPtr != NULL) { + nsPtr = nsPtr->parentPtr; + } + } oPtr->command = TclCreateObjCommandInNs(interp, nameStr, (Tcl_Namespace *)nsPtr, PublicObjectCmd, oPtr, NULL); @@ -673,26 +713,8 @@ AllocObject( tracePtr->nextPtr = NULL; tracePtr->refCount = 1; - /* - * Access the namespace command table directly when creating "my" to avoid - * a bottleneck in string manipulation. Another abstraction-buster. - */ - - cmdPtr = ckalloc(sizeof(Command)); - memset(cmdPtr, 0, sizeof(Command)); - cmdPtr->nsPtr = (Namespace *) oPtr->namespacePtr; - cmdPtr->hPtr = Tcl_CreateHashEntry(&cmdPtr->nsPtr->cmdTable, "my", - &ignored); - cmdPtr->refCount = 1; - cmdPtr->objProc = PrivateObjectCmd; - cmdPtr->deleteProc = MyDeleted; - cmdPtr->objClientData = cmdPtr->deleteData = oPtr; - cmdPtr->proc = TclInvokeObjectCommand; - cmdPtr->clientData = cmdPtr; - cmdPtr->nreProc = PrivateNRObjectCmd; - Tcl_SetHashValue(cmdPtr->hPtr, cmdPtr); - oPtr->myCommand = (Tcl_Command) cmdPtr; - + oPtr->myCommand = TclNRCreateCommandInNs(interp, "my", oPtr->namespacePtr, + PrivateObjectCmd, PrivateNRObjectCmd, oPtr, MyDeleted); return oPtr; } @@ -774,88 +796,20 @@ ObjectRenamedTrace( /* * The namespace is only deleted if it hasn't already been deleted. [Bug - * 2950259]. If the namespace has already been deleted, then - * ObjectNamespaceDeleted() has already cleaned up this command. + * 2950259]. */ - if (oPtr->namespacePtr == NULL) { - /* - * ObjectNamespaceDeleted() has already done all the cleanup, but - * detected that the command was in the process of being deleted, and - * left the pointer allocated for us. - */ - DelRef(oPtr); - } else { - if (((Namespace *) oPtr->namespacePtr)->earlyDeleteProc == NULL) { - /* - * ObjectNamespaceDeleted() called us, and still has some work to - * do, so we leave the pointer allocated for it to finish, and then - * it will deallocate the pointer. - */ - } else { - Tcl_DeleteNamespace(oPtr->namespacePtr); - /* - * ObjectNamespaceDeleted() doesn't know it was us that just - * called, so it left the pointer allocated. - */ - DelRef(oPtr); - } + if (!Deleted(oPtr)) { + Tcl_DeleteNamespace(oPtr->namespacePtr); } + oPtr->command = NULL; + TclOODecrRefCount(oPtr); return; } /* * ---------------------------------------------------------------------- * - * ClearMixins, ClearSuperclasses -- - * - * Utility functions for correctly clearing the list of mixins or - * superclasses of a class. Will ckfree() the list storage. - * - * ---------------------------------------------------------------------- - */ - -static void -ClearMixins( - Class *clsPtr) -{ - int i; - Class *mixinPtr; - - if (clsPtr->mixins.num == 0) { - return; - } - - FOREACH(mixinPtr, clsPtr->mixins) { - TclOORemoveFromMixinSubs(clsPtr, mixinPtr); - } - ckfree(clsPtr->mixins.list); - clsPtr->mixins.list = NULL; - clsPtr->mixins.num = 0; -} - -static void -ClearSuperclasses( - Class *clsPtr) -{ - int i; - Class *superPtr; - - if (clsPtr->superclasses.num == 0) { - return; - } - - FOREACH(superPtr, clsPtr->superclasses) { - TclOORemoveFromSubclasses(clsPtr, superPtr); - } - ckfree(clsPtr->superclasses.list); - clsPtr->superclasses.list = NULL; - clsPtr->superclasses.num = 0; -} - -/* - * ---------------------------------------------------------------------- - * * ReleaseClassContents -- * * Tear down the special class data structure, including deleting all @@ -865,122 +819,39 @@ ClearSuperclasses( */ static void -ReleaseClassContents( +DeleteDescendants( Tcl_Interp *interp, /* The interpreter containing the class. */ Object *oPtr) /* The object representing the class. */ { - FOREACH_HASH_DECLS; - int i; - Class *clsPtr = oPtr->classPtr, *mixinSubclassPtr, *subclassPtr; + Class *clsPtr = oPtr->classPtr, *subclassPtr, *mixinSubclassPtr; Object *instancePtr; - Method *mPtr; - Foundation *fPtr = oPtr->fPtr; - Tcl_Obj *variableObj; - - /* - * Sanity check! - */ - - if (!Deleted(oPtr)) { - if (IsRootClass(oPtr)) { - Tcl_Panic("deleting class structure for non-deleted %s", - "::oo::class"); - } else if (IsRootObject(oPtr)) { - Tcl_Panic("deleting class structure for non-deleted %s", - "::oo::object"); - } else { - Tcl_Panic("deleting class structure for non-deleted %s", - "general object"); - } - } - - /* - * Lock a number of dependent objects until we've stopped putting our - * fingers in them. - */ - - FOREACH(mixinSubclassPtr, clsPtr->mixinSubs) { - if (mixinSubclassPtr != NULL) { - AddRef(mixinSubclassPtr); - AddRef(mixinSubclassPtr->thisPtr); - } - } - FOREACH(subclassPtr, clsPtr->subclasses) { - if (subclassPtr != NULL && !IsRoot(subclassPtr)) { - AddRef(subclassPtr); - AddRef(subclassPtr->thisPtr); - } - } - if (!IsRootClass(oPtr)) { - FOREACH(instancePtr, clsPtr->instances) { - if (instancePtr != oPtr) { - int j; - if (instancePtr->selfCls == clsPtr) { - instancePtr->flags |= CLASS_GONE; - } - for(j=0 ; jmixins.num ; j++) { - Class *mixin = instancePtr->mixins.list[j]; - Class *nextMixin = NULL; - if (mixin == clsPtr) { - if (j < instancePtr->mixins.num - 1) { - nextMixin = instancePtr->mixins.list[j+1]; - } - if (j == 0) { - instancePtr->mixins.num = 0; - instancePtr->mixins.list = NULL; - } else { - instancePtr->mixins.list[j-1] = nextMixin; - } - instancePtr->mixins.num -= 1; - } - } - if (instancePtr != NULL && !IsRoot(instancePtr)) { - AddRef(instancePtr); - } - } - } - } + int i; /* * Squelch classes that this class has been mixed into. */ FOREACH(mixinSubclassPtr, clsPtr->mixinSubs) { - if (mixinSubclassPtr != clsPtr) { - if (!Deleted(mixinSubclassPtr->thisPtr)) { - Tcl_DeleteCommandFromToken(interp, - mixinSubclassPtr->thisPtr->command); - } - ClearMixins(mixinSubclassPtr); - DelRef(mixinSubclassPtr->thisPtr); - DelRef(mixinSubclassPtr); + /* This condition also covers the case where mixinSubclassPtr == + * clsPtr + */ + if (!Deleted(mixinSubclassPtr->thisPtr)) { + Tcl_DeleteCommandFromToken(interp, + mixinSubclassPtr->thisPtr->command); } + i -= TclOORemoveFromMixinSubs(mixinSubclassPtr, clsPtr); + TclOODecrRefCount(mixinSubclassPtr->thisPtr); } - if (clsPtr->mixinSubs.list != NULL) { - ckfree(clsPtr->mixinSubs.list); - clsPtr->mixinSubs.list = NULL; - clsPtr->mixinSubs.num = 0; - } - /* * Squelch subclasses of this class. */ FOREACH(subclassPtr, clsPtr->subclasses) { - if (IsRoot(subclassPtr)) { - continue; - } - if (!Deleted(subclassPtr->thisPtr)) { + if (!Deleted(subclassPtr->thisPtr) && !IsRoot(subclassPtr)) { Tcl_DeleteCommandFromToken(interp, subclassPtr->thisPtr->command); } - ClearSuperclasses(subclassPtr); - DelRef(subclassPtr->thisPtr); - DelRef(subclassPtr); - } - if (clsPtr->subclasses.list != NULL) { - ckfree(clsPtr->subclasses.list); - clsPtr->subclasses.list = NULL; - clsPtr->subclasses.num = 0; + i -= TclOORemoveFromSubclasses(subclassPtr, clsPtr); + TclOODecrRefCount(subclassPtr->thisPtr); } /* @@ -989,35 +860,43 @@ ReleaseClassContents( if (!IsRootClass(oPtr)) { FOREACH(instancePtr, clsPtr->instances) { - if (instancePtr != oPtr) { - if (instancePtr == NULL || IsRoot(instancePtr)) { - continue; - } - if (!Deleted(instancePtr)) { - Tcl_DeleteCommandFromToken(interp, instancePtr->command); - /* - * Tcl_DeleteCommandFromToken() may have done to whole - * job for us. Roll back and check again. - */ - i--; - continue; - } - DelRef(instancePtr); + /* This condition also covers the case where instancePtr == oPtr */ + if (!Deleted(instancePtr) && !IsRoot(instancePtr)) { + Tcl_DeleteCommandFromToken(interp, instancePtr->command); } + i -= TclOORemoveFromInstances(instancePtr, clsPtr); } } - if (clsPtr->instances.list != NULL) { - ckfree(clsPtr->instances.list); - clsPtr->instances.list = NULL; - clsPtr->instances.num = 0; - } +} + + +static void +ReleaseClassContents( + Tcl_Interp *interp, /* The interpreter containing the class. */ + Object *oPtr) /* The object representing the class. */ +{ + FOREACH_HASH_DECLS; + int i; + Class *clsPtr = oPtr->classPtr, *tmpClsPtr; + Method *mPtr; + Foundation *fPtr = oPtr->fPtr; + Tcl_Obj *variableObj; /* - * Special: We delete these after everything else. + * Sanity check! */ - if (IsRootClass(oPtr) && !Deleted(fPtr->objectCls->thisPtr)) { - Tcl_DeleteCommandFromToken(interp, fPtr->objectCls->thisPtr->command); + if (!Deleted(oPtr)) { + if (IsRootClass(oPtr)) { + Tcl_Panic("deleting class structure for non-deleted %s", + "::oo::class"); + } else if (IsRootObject(oPtr)) { + Tcl_Panic("deleting class structure for non-deleted %s", + "::oo::object"); + } else { + Tcl_Panic("deleting class structure for non-deleted %s", + "general object"); + } } /* @@ -1073,8 +952,12 @@ ReleaseClassContents( clsPtr->metadataPtr = NULL; } - ClearMixins(clsPtr); - ClearSuperclasses(clsPtr); + FOREACH(tmpClsPtr, clsPtr->mixins) { + TclOORemoveFromMixinSubs(clsPtr, tmpClsPtr); + } + FOREACH(tmpClsPtr, clsPtr->superclasses) { + TclOORemoveFromSubclasses(clsPtr, tmpClsPtr); + } FOREACH_HASH_VALUE(mPtr, &clsPtr->classMethods) { TclOODelMethodRef(mPtr); @@ -1090,12 +973,9 @@ ReleaseClassContents( ckfree(clsPtr->variables.list); } - /* Tell oPtr that it's class is gone so that it doesn't try to remove - * itself from it's classe's list of instances - */ - oPtr->flags |= CLASS_GONE; - DelRef(clsPtr); - + if (IsRootClass(oPtr) && !Deleted(fPtr->objectCls->thisPtr)) { + Tcl_DeleteCommandFromToken(interp, fPtr->objectCls->thisPtr->command); + } } /* @@ -1123,13 +1003,26 @@ ObjectNamespaceDeleted( Method *mPtr; Tcl_Obj *filterObj, *variableObj; Tcl_Interp *interp = oPtr->fPtr->interp; - int finished = 0, i; + int i; + if (Deleted(oPtr)) { + /* To do: Can ObjectNamespaceDeleted ever be called twice? If not, + * this guard could be removed. + */ + return; + } - AddRef(fPtr->classCls); - AddRef(fPtr->objectCls); - AddRef(fPtr->classCls->thisPtr); - AddRef(fPtr->objectCls->thisPtr); + /* + * One rule for the teardown routines is that if an object is in the + * process of being deleted, nothing else may modify its bookeeping + * records. This is the flag that + */ + oPtr->flags |= OBJECT_DELETED; + + /* Let the dominoes fall */ + if (oPtr->classPtr) { + DeleteDescendants(interp, oPtr); + } /* * We do not run destructors on the core class objects when the @@ -1137,15 +1030,14 @@ ObjectNamespaceDeleted( * in that case when the destructor is partially deleted before the uses * of it have gone. [Bug 2949397] */ - - if (!(oPtr->flags & DESTRUCTOR_CALLED) && !Tcl_InterpDeleted(interp)) { + if (!Tcl_InterpDeleted(interp) && !(oPtr->flags & DESTRUCTOR_CALLED)) { CallContext *contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL); int result; Tcl_InterpState state; - oPtr->flags |= DESTRUCTOR_CALLED; + if (contextPtr != NULL) { contextPtr->callPtr->flags |= DESTRUCTOR; contextPtr->skip = 0; @@ -1167,7 +1059,7 @@ ObjectNamespaceDeleted( * points into freed memory. */ - if ((((Command *)oPtr->command)->flags && CMD_IS_DELETED)) { + if (((Command *)oPtr->command)->flags && CMD_IS_DELETED) { /* * Something has already started the command deletion process. We can * go ahead and clean up the the namespace, @@ -1178,9 +1070,7 @@ ObjectNamespaceDeleted( * as well. */ Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command); - finished = 1; } - oPtr->command = NULL; if (oPtr->myCommand) { Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myCommand); @@ -1191,14 +1081,13 @@ ObjectNamespaceDeleted( * methods on the object. */ - if (!IsRootObject(oPtr) && !(oPtr->flags & CLASS_GONE)) { - TclOORemoveFromInstances(oPtr, oPtr->selfCls); - } + /* To do: Get dkf to weigh in on wether this should be protected with a + * !IsRoot() condition. + */ + TclOORemoveFromInstances(oPtr, oPtr->selfCls); FOREACH(mixinPtr, oPtr->mixins) { - if (mixinPtr && mixinPtr != oPtr->classPtr) { - TclOORemoveFromInstances(oPtr, mixinPtr); - } + i -= TclOORemoveFromInstances(oPtr, mixinPtr); } if (i) { ckfree(oPtr->mixins.list); @@ -1258,8 +1147,9 @@ ObjectNamespaceDeleted( * classes, if one goes the other must too and yet the tangle can * sometimes not go away automatically; we force it here. [Bug 2962664] */ - if (!Tcl_InterpDeleted(interp) && IsRootObject(oPtr) - && !Deleted(fPtr->classCls->thisPtr)) { + if (IsRootObject(oPtr) && !Deleted(fPtr->classCls->thisPtr) + && !Tcl_InterpDeleted(interp)) { + Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command); } @@ -1267,35 +1157,59 @@ ObjectNamespaceDeleted( ReleaseClassContents(interp, oPtr); } - /* * Delete the object structure itself. */ - oPtr->classPtr = NULL; oPtr->namespacePtr = NULL; - - DelRef(fPtr->classCls->thisPtr); - DelRef(fPtr->objectCls->thisPtr); - DelRef(fPtr->classCls); - DelRef(fPtr->objectCls); - if (finished) { - /* - * ObjectRenamedTrace called us, and not the other way around. - */ - DelRef(oPtr); - } else { - /* - * ObjectRenamedTrace will call DelRef(oPtr). - */ - } + oPtr->selfCls = NULL; + TclOODecrRefCount(oPtr); return; - } /* * ---------------------------------------------------------------------- * + * TclOODecrRef -- + * + * Decrement the refcount of an object and deallocate storage then object + * is no longer referenced. Returns 1 if storage was deallocated, and 0 + * otherwise. + * + * ---------------------------------------------------------------------- + */ +int TclOODecrRefCount(Object *oPtr) { + if (oPtr->refCount-- <= 1) { + Class *clsPtr = oPtr->classPtr; + if (oPtr->classPtr != NULL) { + ckfree(clsPtr->superclasses.list); + ckfree(clsPtr->subclasses.list); + ckfree(clsPtr->instances.list); + ckfree(clsPtr->mixinSubs.list); + ckfree(clsPtr->mixins.list); + ckfree(oPtr->classPtr); + } + ckfree(oPtr); + return 1; + } + return 0; +} + +/* setting the "empty" location to NULL makes debugging a little easier */ +#define REMOVEBODY { \ + for (; idx < num - 1; idx++) { \ + list[idx] = list[idx+1]; \ + } \ + list[idx] = NULL; \ + return; \ +} +void RemoveClass(Class **list, int num, int idx) REMOVEBODY + +void RemoveObject(Object **list, int num, int idx) REMOVEBODY + +/* + * ---------------------------------------------------------------------- + * * TclOORemoveFromInstances -- * * Utility function to remove an object from the list of instances within @@ -1304,36 +1218,27 @@ ObjectNamespaceDeleted( * ---------------------------------------------------------------------- */ -void +int TclOORemoveFromInstances( Object *oPtr, /* The instance to remove. */ Class *clsPtr) /* The class (possibly) containing the * reference to the instance. */ { - int i; + int i, res = 0; Object *instPtr; + if (Deleted(clsPtr->thisPtr)) { + return res; + } FOREACH(instPtr, clsPtr->instances) { if (oPtr == instPtr) { - goto removeInstance; - } - } - return; - - removeInstance: - if (Deleted(clsPtr->thisPtr)) { - if (!IsRootClass(clsPtr)) { - DelRef(clsPtr->instances.list[i]); - } - clsPtr->instances.list[i] = NULL; - } else { - clsPtr->instances.num--; - if (i < clsPtr->instances.num) { - clsPtr->instances.list[i] = - clsPtr->instances.list[clsPtr->instances.num]; + RemoveItem(Object, clsPtr->instances, i); + TclOODecrRefCount(oPtr); + res++; + break; } - clsPtr->instances.list[clsPtr->instances.num] = NULL; } + return res; } /* @@ -1354,9 +1259,6 @@ TclOOAddToInstances( * assumed that the class is not already * present as an instance in the class. */ { - if (Deleted(clsPtr->thisPtr)) { - return; - } if (clsPtr->instances.num >= clsPtr->instances.size) { clsPtr->instances.size += ALLOC_CHUNK; if (clsPtr->instances.size == ALLOC_CHUNK) { @@ -1367,6 +1269,7 @@ TclOOAddToInstances( } } clsPtr->instances.list[clsPtr->instances.num++] = oPtr; + AddRef(oPtr); } /* @@ -1375,36 +1278,31 @@ TclOOAddToInstances( * TclOORemoveFromSubclasses -- * * Utility function to remove a class from the list of subclasses within - * another class. + * another class. Returns the number of removals performed. * * ---------------------------------------------------------------------- */ -void +int TclOORemoveFromSubclasses( Class *subPtr, /* The subclass to remove. */ Class *superPtr) /* The superclass to possibly remove the * subclass reference from. */ { - int i; + int i, res = 0; Class *subclsPtr; + if (Deleted(superPtr->thisPtr)) { + return res; + } FOREACH(subclsPtr, superPtr->subclasses) { if (subPtr == subclsPtr) { - goto removeSubclass; - } - } - return; - - removeSubclass: - if (!Deleted(superPtr->thisPtr)) { - superPtr->subclasses.num--; - if (i < superPtr->subclasses.num) { - superPtr->subclasses.list[i] = - superPtr->subclasses.list[superPtr->subclasses.num]; + RemoveItem(Class, superPtr->subclasses, i); + TclOODecrRefCount(subPtr->thisPtr); + res++; } - superPtr->subclasses.list[superPtr->subclasses.num] = NULL; } + return res; } /* @@ -1431,13 +1329,13 @@ TclOOAddToSubclasses( if (superPtr->subclasses.num >= superPtr->subclasses.size) { superPtr->subclasses.size += ALLOC_CHUNK; if (superPtr->subclasses.size == ALLOC_CHUNK) { - superPtr->subclasses.list = ckalloc(sizeof(Class*) * ALLOC_CHUNK); + superPtr->subclasses.list = ckalloc(sizeof(Class *) * ALLOC_CHUNK); } else { - superPtr->subclasses.list = ckrealloc(superPtr->subclasses.list, - sizeof(Class *) * superPtr->subclasses.size); + superPtr->subclasses.list = ckrealloc(superPtr->subclasses.list, sizeof(Class *) * superPtr->subclasses.size); } } superPtr->subclasses.list[superPtr->subclasses.num++] = subPtr; + AddRef(subPtr->thisPtr); } /* @@ -1451,31 +1349,28 @@ TclOOAddToSubclasses( * ---------------------------------------------------------------------- */ -void +int TclOORemoveFromMixinSubs( Class *subPtr, /* The subclass to remove. */ Class *superPtr) /* The superclass to possibly remove the * subclass reference from. */ { - int i; + int i, res = 0; Class *subclsPtr; - FOREACH(subclsPtr, superPtr->mixinSubs) { - if (subPtr == subclsPtr) { - goto removeSubclass; - } + if (Deleted(superPtr->thisPtr)) { + return res; } - return; - removeSubclass: - if (!Deleted(superPtr->thisPtr)) { - superPtr->mixinSubs.num--; - if (i < superPtr->mixinSubs.num) { - superPtr->mixinSubs.list[i] = - superPtr->mixinSubs.list[superPtr->mixinSubs.num]; + FOREACH(subclsPtr, superPtr->mixinSubs) { + if (subPtr == subclsPtr) { + RemoveItem(Class, superPtr->mixinSubs, i); + TclOODecrRefCount(subPtr->thisPtr); + res++; + break; } - superPtr->mixinSubs.list[superPtr->mixinSubs.num] = NULL; } + return res; } /* @@ -1509,6 +1404,7 @@ TclOOAddToMixinSubs( } } superPtr->mixinSubs.list[superPtr->mixinSubs.num++] = subPtr; + AddRef(subPtr->thisPtr); } /* @@ -1516,7 +1412,7 @@ TclOOAddToMixinSubs( * * AllocClass -- * - * Allocate a basic class. Does not splice the class object into its + * Allocate a basic class. Does not add class to its * class's instance list. * * ---------------------------------------------------------------------- @@ -1527,44 +1423,18 @@ AllocClass( Tcl_Interp *interp, /* Interpreter within which to allocate the * class. */ Object *useThisObj) /* Object that is to act as the class - * representation, or NULL if a new object - * with automatic name is to be used. */ + * representation. */ { Foundation *fPtr = GetFoundation(interp); Class *clsPtr = ckalloc(sizeof(Class)); - /* - * Make an object if we haven't been given one. - */ - memset(clsPtr, 0, sizeof(Class)); - if (useThisObj == NULL) { - clsPtr->thisPtr = AllocObject(interp, NULL, NULL, NULL); - } else { - clsPtr->thisPtr = useThisObj; - } + clsPtr->thisPtr = useThisObj; /* * Configure the namespace path for the class's object. */ - - if (fPtr->helpersNs != NULL) { - Tcl_Namespace *path[2]; - - path[0] = fPtr->helpersNs; - path[1] = fPtr->ooNs; - TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 2, path); - } else { - TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 1, - &fPtr->ooNs); - } - - /* - * Class objects inherit from the class of classes unless they inherit - * from some subclass of it. Enforce this right now. - */ - - clsPtr->thisPtr->selfCls = fPtr->classCls; + initClassPath(interp, clsPtr); /* * Classes are subclasses of oo::object, i.e. the objects they create are @@ -1574,6 +1444,7 @@ AllocClass( clsPtr->superclasses.num = 1; clsPtr->superclasses.list = ckalloc(sizeof(Class *)); clsPtr->superclasses.list[0] = fPtr->objectCls; + AddRef(fPtr->objectCls->thisPtr); /* * Finish connecting the class structure to the object structure. @@ -1586,10 +1457,22 @@ AllocClass( * fields. */ - clsPtr->refCount = 1; Tcl_InitObjHashTable(&clsPtr->classMethods); return clsPtr; } +static void +initClassPath(Tcl_Interp *interp, Class *clsPtr) { + Foundation *fPtr = GetFoundation(interp); + if (fPtr->helpersNs != NULL) { + Tcl_Namespace *path[2]; + path[0] = fPtr->helpersNs; + path[1] = fPtr->ooNs; + TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 2, path); + } else { + TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 1, + &fPtr->ooNs); + } +} /* * ---------------------------------------------------------------------- @@ -1640,7 +1523,7 @@ Tcl_NewObjectInstance( contextPtr->skip = skip; /* - * Adjust the ensmble tracking record if necessary. [Bug 3514761] + * Adjust the ensemble tracking record if necessary. [Bug 3514761] */ isRoot = TclInitRewriteEnsemble(interp, skip, skip, objv); @@ -1656,7 +1539,6 @@ Tcl_NewObjectInstance( clientData[2] = state; clientData[3] = &oPtr; - AddRef(oPtr); result = FinalizeAlloc(clientData, interp, result); if (result != TCL_OK) { return NULL; @@ -1723,7 +1605,6 @@ TclNRNewObjectInstance( * Fire off the constructors non-recursively. */ - AddRef(oPtr); TclNRAddCallback(interp, FinalizeAlloc, contextPtr, oPtr, state, objectPtr); TclPushTailcallPoint(interp); @@ -1771,18 +1652,9 @@ TclNewObjectInstanceCommon( * Create the object. */ - /* - * The command for the object could have the same name as the command - * associated with classPtr, so protect the structure from deallocation - * here. - */ - AddRef(classPtr); - oPtr = AllocObject(interp, simpleName, nsPtr, nsNameStr); - DelRef(classPtr); oPtr->selfCls = classPtr; TclOOAddToInstances(oPtr, classPtr); - /* * Check to see if we're really creating a class. If so, allocate the * class structure as well. @@ -1797,7 +1669,6 @@ TclNewObjectInstanceCommon( */ AllocClass(interp, oPtr); - oPtr->selfCls = classPtr; TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls); } else { oPtr->classPtr = NULL; @@ -1829,7 +1700,6 @@ FinalizeAlloc( Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL); result = TCL_ERROR; } - TclOODeleteContext(contextPtr); if (result != TCL_OK) { Tcl_DiscardInterpState(state); @@ -1843,12 +1713,14 @@ FinalizeAlloc( (void) TclOOObjectName(interp, oPtr); Tcl_DeleteCommandFromToken(interp, oPtr->command); } - DelRef(oPtr); + /* This decrements the refcount of oPtr */ + TclOODeleteContext(contextPtr); return TCL_ERROR; } Tcl_RestoreInterpState(interp, state); *objectPtr = (Tcl_Object) oPtr; - DelRef(oPtr); + /* This decrements the refcount of oPtr */ + TclOODeleteContext(contextPtr); return TCL_OK; } @@ -1956,8 +1828,7 @@ Tcl_CopyObjectInstance( */ o2Ptr->flags = oPtr->flags & ~( - OBJECT_DELETED | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING); - + OBJECT_DELETED | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING); /* * Copy the object's metadata. */ @@ -2969,7 +2840,7 @@ int Tcl_ObjectDeleted( Tcl_Object object) { - return Deleted(object) ? 1 : 0; + return Deleted((Object *)object) ? 1 : 0; } Tcl_Object diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index b2c06a7..84f414d 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -340,11 +340,6 @@ TclOO_Object_Destroy( Object *oPtr = (Object *) Tcl_ObjectContextObject(context); CallContext *contextPtr; - if (objc != Tcl_ObjectContextSkippedArgs(context)) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - NULL); - return TCL_ERROR; - } if (!(oPtr->flags & DESTRUCTOR_CALLED)) { oPtr->flags |= DESTRUCTOR_CALLED; contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL); diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index d4e1e34..c71425b 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -110,7 +110,8 @@ TclOODeleteContext( TclOODeleteChain(contextPtr->callPtr); if (oPtr != NULL) { TclStackFree(oPtr->fPtr->interp, contextPtr); - DelRef(oPtr); + /* Corresponding AddRef() in TclOO.c/TclOOObjectCmdCore */ + TclOODecrRefCount(oPtr); } } @@ -1171,6 +1172,7 @@ TclOOGetCallContext( returnContext: contextPtr = TclStackAlloc(oPtr->fPtr->interp, sizeof(CallContext)); contextPtr->oPtr = oPtr; + /* Corresponding TclOODecrRefCount() in TclOODeleteContext */ AddRef(oPtr); contextPtr->callPtr = callPtr; contextPtr->skip = 2; diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index b0bfd9c..7f3ea18 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -326,9 +326,7 @@ TclOOObjectSetMixins( if (numMixins == 0) { if (oPtr->mixins.num != 0) { FOREACH(mixinPtr, oPtr->mixins) { - if (mixinPtr) { - TclOORemoveFromInstances(oPtr, mixinPtr); - } + TclOORemoveFromInstances(oPtr, mixinPtr); } ckfree(oPtr->mixins.list); oPtr->mixins.num = 0; @@ -352,6 +350,10 @@ TclOOObjectSetMixins( FOREACH(mixinPtr, oPtr->mixins) { if (mixinPtr != oPtr->selfCls) { TclOOAddToInstances(oPtr, mixinPtr); + /* Corresponding TclOODecrRefCount() is in the caller of this + * function. + */ + TclOODecrRefCount(mixinPtr->thisPtr); } } } @@ -399,6 +401,10 @@ TclOOClassSetMixins( memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins); FOREACH(mixinPtr, classPtr->mixins) { TclOOAddToMixinSubs(classPtr, mixinPtr); + /* Corresponding TclOODecrRefCount() is in the caller of this + * function + */ + TclOODecrRefCount(mixinPtr->thisPtr); } } BumpGlobalEpoch(interp, classPtr); @@ -914,7 +920,7 @@ TclOODefineObjCmd( } else { result = MagicDefinitionInvoke(interp, fPtr->defineNs, 2, objc, objv); } - DelRef(oPtr); + TclOODecrRefCount(oPtr); /* * Restore the previous "current" namespace. @@ -981,7 +987,7 @@ TclOOObjDefObjCmd( } else { result = MagicDefinitionInvoke(interp, fPtr->objdefNs, 2, objc, objv); } - DelRef(oPtr); + TclOODecrRefCount(oPtr); /* * Restore the previous "current" namespace. @@ -1048,7 +1054,7 @@ TclOODefineSelfObjCmd( } else { result = MagicDefinitionInvoke(interp, fPtr->objdefNs, 1, objc, objv); } - DelRef(oPtr); + TclOODecrRefCount(oPtr); /* * Restore the previous "current" namespace. @@ -1168,11 +1174,11 @@ TclOODefineClassObjCmd( if (oPtr->selfCls != clsPtr) { TclOORemoveFromInstances(oPtr, oPtr->selfCls); + + /* Reference count already incremented 3 lines up. */ oPtr->selfCls = clsPtr; + TclOOAddToInstances(oPtr, oPtr->selfCls); - if (!(clsPtr->thisPtr->flags & OBJECT_DELETED)) { - oPtr->flags &= ~CLASS_GONE; - } if (oPtr->classPtr != NULL) { BumpGlobalEpoch(interp, oPtr->classPtr); } else { @@ -1628,6 +1634,10 @@ TclOODefineMixinObjCmd( goto freeAndError; } mixins[i-1] = clsPtr; + /* Corresponding TclOODecrRefCount() is in TclOOObjectSetMixins, + * TclOOClassSetMixinsk, or just below if this function fails. + */ + AddRef(mixins[i-1]->thisPtr); } if (isInstanceMixin) { @@ -1640,6 +1650,9 @@ TclOODefineMixinObjCmd( return TCL_OK; freeAndError: + while (--i > 0) { + TclOODecrRefCount(mixins[i]->thisPtr); + } TclStackFree(interp, mixins); return TCL_ERROR; } @@ -2055,6 +2068,7 @@ ClassMixinSet( mixins[i] = GetClassInOuterContext(interp, mixinv[i], "may only mix in classes"); if (mixins[i] == NULL) { + i--; goto freeAndError; } if (TclOOIsReachable(oPtr->classPtr, mixins[i])) { @@ -2063,6 +2077,10 @@ ClassMixinSet( Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL); goto freeAndError; } + /* Corresponding TclOODecrRefCount() is in TclOOClassSetMixins, or just + * below if this function fails + */ + AddRef(mixins[i]->thisPtr); } TclOOClassSetMixins(interp, oPtr->classPtr, mixinc, mixins); @@ -2070,6 +2088,9 @@ ClassMixinSet( return TCL_OK; freeAndError: + while (i-- > 0) { + TclOODecrRefCount(mixins[i]->thisPtr); + } TclStackFree(interp, mixins); return TCL_ERROR; } @@ -2172,16 +2193,20 @@ ClassSuperSet( if (superc == 0) { superclasses = ckrealloc(superclasses, sizeof(Class *)); - superclasses[0] = oPtr->fPtr->objectCls; - superc = 1; if (TclOOIsReachable(oPtr->fPtr->classCls, oPtr->classPtr)) { superclasses[0] = oPtr->fPtr->classCls; + } else { + superclasses[0] = oPtr->fPtr->objectCls; } + superc = 1; + /* Corresponding TclOODecrRefCount is near the end of this function */ + AddRef(superclasses[0]->thisPtr); } else { for (i=0 ; i 0; i--) { + TclOODecrRefCount(superclasses[i]->thisPtr); + } ckfree(superclasses); return TCL_ERROR; } + /* Corresponding TclOODecrRefCount() is near the end of this + * function */ + AddRef(superclasses[i]->thisPtr); } } @@ -2221,6 +2252,8 @@ ClassSuperSet( oPtr->classPtr->superclasses.num = superc; FOREACH(superPtr, oPtr->classPtr->superclasses) { TclOOAddToSubclasses(oPtr->classPtr, superPtr); + /* To account for the AddRef() earlier in this function */ + TclOODecrRefCount(superPtr->thisPtr); } BumpGlobalEpoch(interp, oPtr->classPtr); @@ -2511,9 +2544,16 @@ ObjMixinSet( mixins[i] = GetClassInOuterContext(interp, mixinv[i], "may only mix in classes"); if (mixins[i] == NULL) { + while (i-- > 0) { + TclOODecrRefCount(mixins[i]->thisPtr); + } TclStackFree(interp, mixins); return TCL_ERROR; } + /* Corresponding TclOODecrRefCount() is in TclOOObjectSetMixins() or + * just above if this function fails. + */ + AddRef(mixins[i]->thisPtr); } TclOOObjectSetMixins(oPtr, mixinc, mixins); diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 83b4d58..084c026 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -193,9 +193,10 @@ typedef struct Object { * destroyed. */ #define DESTRUCTOR_CALLED 2 /* Flag to say that the destructor has been * called. */ -#define CLASS_GONE 4 /* Indicates that the class of this object has - * been deleted, and so the object should not - * attempt to remove itself from its class. */ +#define CLASS_GONE 4 /* Obsolete. Indicates that the class of this + * object has been deleted, and so the object + * should not attempt to remove itself from its + * class. */ #define ROOT_OBJECT 0x1000 /* Flag to say that this object is the root of * the class hierarchy and should be treated * specially during teardown. */ @@ -222,10 +223,6 @@ typedef struct Object { typedef struct Class { Object *thisPtr; /* Reference to the object associated with * this class. */ - int refCount; /* Number of strong references to this class. - * Weak references are not counted; the - * purpose of this is to avoid Tcl_Preserve as - * that is quite slow. */ int flags; /* Assorted flags. */ LIST_STATIC(struct Class *) superclasses; /* List of superclasses, used for generation @@ -499,6 +496,7 @@ MODULE_SCOPE Object * TclNewObjectInstanceCommon(Tcl_Interp *interp, Class *classPtr, const char *nameStr, const char *nsNameStr); +MODULE_SCOPE int TclOODecrRefCount(Object *oPtr); MODULE_SCOPE int TclOODefineSlots(Foundation *fPtr); MODULE_SCOPE void TclOODeleteChain(CallChain *callPtr); MODULE_SCOPE void TclOODeleteChainCache(Tcl_HashTable *tablePtr); @@ -528,10 +526,10 @@ MODULE_SCOPE int TclNRObjectContextInvokeNext(Tcl_Interp *interp, MODULE_SCOPE void TclOONewBasicMethod(Tcl_Interp *interp, Class *clsPtr, const DeclaredClassMethod *dcm); MODULE_SCOPE Tcl_Obj * TclOOObjectName(Tcl_Interp *interp, Object *oPtr); -MODULE_SCOPE void TclOORemoveFromInstances(Object *oPtr, Class *clsPtr); -MODULE_SCOPE void TclOORemoveFromMixinSubs(Class *subPtr, +MODULE_SCOPE int TclOORemoveFromInstances(Object *oPtr, Class *clsPtr); +MODULE_SCOPE int TclOORemoveFromMixinSubs(Class *subPtr, Class *mixinPtr); -MODULE_SCOPE void TclOORemoveFromSubclasses(Class *subPtr, +MODULE_SCOPE int TclOORemoveFromSubclasses(Class *subPtr, Class *superPtr); MODULE_SCOPE Tcl_Obj * TclOORenderCallChain(Tcl_Interp *interp, CallChain *callPtr); @@ -546,18 +544,21 @@ MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr); #include "tclOOIntDecls.h" /* + * Alternatives to Tcl_Preserve/Tcl_EventuallyFree/Tcl_Release. + */ + +#define AddRef(ptr) ((ptr)->refCount++) + +/* * A convenience macro for iterating through the lists used in the internal - * memory management of objects. This is a bit gnarly because we want to do - * the assignment of the picked-out value only when the body test succeeds, - * but we cannot rely on the assigned value being useful, forcing us to do - * some nasty stuff with the comma operator. The compiler's optimizer should - * be able to sort it all out! - * + * memory management of objects. * REQUIRES DECLARATION: int i; */ #define FOREACH(var,ary) \ - for(i=0 ; (i<(ary).num?((var=(ary).list[i]),1):0) ; i++) + for(i=0 ; i<(ary).num; i++) if ((ary).list[i] == NULL) { \ + continue; \ + } else if (var = (ary).list[i], 1) /* * Convenience macros for iterating through hash tables. FOREACH_HASH_DECLS @@ -592,17 +593,6 @@ MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr); } \ } while(0) -/* - * Alternatives to Tcl_Preserve/Tcl_EventuallyFree/Tcl_Release. - */ - -#define AddRef(ptr) ((ptr)->refCount++) -#define DelRef(ptr) do { \ - if ((ptr)->refCount-- <= 1) { \ - ckfree(ptr); \ - } \ - } while(0) - #endif /* TCL_OO_INTERNAL_H */ /* diff --git a/tests/oo.test b/tests/oo.test index b9c5067..3be5f79 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -47,7 +47,7 @@ test oo-0.2 {basic test of OO's ability to clean up its initial state} { } {} test oo-0.3 {basic test of OO's ability to clean up its initial state} -body { leaktest { - [oo::object new] destroy + [oo::object new] destroy } } -constraints memory -result 0 test oo-0.4 {basic test of OO's ability to clean up its initial state} -body { @@ -131,6 +131,10 @@ test oo-1.4 {basic test of OO functionality} -body { test oo-1.4.1 {fully-qualified nested name} -body { oo::object create ::one::two::three } -result {::one::two::three} +test oo-1.4.2 {automatic command name has same name as namespace} -body { + set obj [oo::object new] + expr {[info object namespace $obj] == $obj} +} -result 1 test oo-1.5 {basic test of OO functionality} -body { oo::object doesnotexist } -returnCodes 1 -result {unknown method "doesnotexist": must be create, destroy or new} @@ -1514,9 +1518,9 @@ test oo-11.6 { # No segmentation fault return done -} -cleanup { +} -result done -cleanup { rename obj1 {} -} -result done +} test oo-12.1 {OO: filters} { oo::class create Aclass @@ -3891,9 +3895,6 @@ test oo-35.6 { rename obj {} } -result done - - - test oo-36.1 {TIP #470: introspection within oo::define} { oo::define oo::object self } ::oo::object -- cgit v0.12 From 0239e7e77f3f12c24179f6c021d3f7b40dfcf981 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Mon, 11 Dec 2017 23:50:22 +0000 Subject: Add the check for wrong arguments back to TclOO_Object_Destroy, remove inadvertant increment of Namespace->refCount. --- generic/tclBasic.c | 1 - generic/tclOO.c | 4 +++- generic/tclOOBasic.c | 5 +++++ 3 files changed, 8 insertions(+), 2 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index a23100e..ce46cd4 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -3153,7 +3153,6 @@ Tcl_DeleteCommandFromToken( cmdPtr->nsPtr->refCount++; - cmdPtr->nsPtr->refCount++; if (cmdPtr->tracePtr != NULL) { CommandTrace *tracePtr; CallCommandTraces(iPtr,cmdPtr,NULL,NULL,TCL_TRACE_DELETE); diff --git a/generic/tclOO.c b/generic/tclOO.c index ae1ae3f..1a9bfc4 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -236,8 +236,10 @@ MODULE_SCOPE const TclOOStubs tclOOStubs; #define IsRoot(ocPtr) ((ocPtr)->flags & (ROOT_OBJECT|ROOT_CLASS)) #define RemoveItem(type, lst, i) \ + do { \ Remove ## type ((lst).list, (lst).num, i); \ - (lst).num-- + (lst).num-- \ + } while 0 /* * ---------------------------------------------------------------------- diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 84f414d..b2c06a7 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -340,6 +340,11 @@ TclOO_Object_Destroy( Object *oPtr = (Object *) Tcl_ObjectContextObject(context); CallContext *contextPtr; + if (objc != Tcl_ObjectContextSkippedArgs(context)) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + NULL); + return TCL_ERROR; + } if (!(oPtr->flags & DESTRUCTOR_CALLED)) { oPtr->flags |= DESTRUCTOR_CALLED; contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL); -- cgit v0.12 From 3ddcb1cfb5dd70afa094e3113ab1946df9cbe222 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Wed, 13 Dec 2017 12:56:02 +0000 Subject: Fix syntax error in previous commit. --- generic/tclOO.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 1a9bfc4..0243c15 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -238,8 +238,8 @@ MODULE_SCOPE const TclOOStubs tclOOStubs; #define RemoveItem(type, lst, i) \ do { \ Remove ## type ((lst).list, (lst).num, i); \ - (lst).num-- \ - } while 0 + (lst).num--; \ + } while (0) /* * ---------------------------------------------------------------------- -- cgit v0.12 From 9a7ce78e965b9066530810b359b0b968667de251 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 28 Dec 2017 18:45:16 +0000 Subject: Make Tcl_WinTCharToUtf/Tcl_WinUtfToTChar work when TCL_UTF_MAX > 3, mainly when sizeof(Tcl_UniChar) != 2. --- doc/Encoding.3 | 4 ---- generic/tclStubInit.c | 34 +++++++++++++++++++++++++++++- unix/tclUnixPort.h | 4 ++-- win/tclWin32Dll.c | 57 +++++++++++++++++++++++++++++++++++++++------------ 4 files changed, 79 insertions(+), 20 deletions(-) diff --git a/doc/Encoding.3 b/doc/Encoding.3 index 81ef508..79fca0f 100644 --- a/doc/Encoding.3 +++ b/doc/Encoding.3 @@ -260,10 +260,6 @@ Windows-only convenience functions for converting between UTF-8 and Windows strings based on the TCHAR type which is by convention a Unicode character on Windows NT. -These functions are essentially wrappers around -\fBTcl_UtfToExternalDString\fR and -\fBTcl_ExternalToUtfDString\fR that convert to and from the -Unicode encoding. .PP \fBTcl_GetEncodingName\fR is roughly the inverse of \fBTcl_GetEncoding\fR. Given an \fIencoding\fR, the return value is the \fIname\fR argument that diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index b185f04..679a12b 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -106,7 +106,9 @@ static unsigned short TclWinNToHS(unsigned short ns) { # define TclWinFlushDirtyChannels doNothing # define TclWinResetInterfaces doNothing +#if TCL_UTF_MAX < 4 static Tcl_Encoding winTCharEncoding; +#endif static int TclpIsAtty(int fd) @@ -127,7 +129,7 @@ void *TclWinGetTclInstance() { void *hInstance = NULL; GetModuleHandleExW(GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS, - (const char *)&winTCharEncoding, &hInstance); + (const char *)&TclpIsAtty, &hInstance); return hInstance; } @@ -186,11 +188,24 @@ Tcl_WinUtfToTChar( int len, Tcl_DString *dsPtr) { +#if TCL_UTF_MAX > 3 + WCHAR *wp; + int size = MultiByteToWideChar(CP_UTF8, 0, string, len, 0, 0); + + Tcl_DStringInit(dsPtr); + Tcl_DStringSetLength(dsPtr, 2*size+2); + wp = (WCHAR *)Tcl_DStringValue(dsPtr); + MultiByteToWideChar(CP_UTF8, 0, string, len, wp, size+1); + Tcl_DStringSetLength(dsPtr, 2*size); + wp[size] = 0; + return (char *)wp; +#else if (!winTCharEncoding) { winTCharEncoding = Tcl_GetEncoding(0, "unicode"); } return Tcl_UtfToExternalDString(winTCharEncoding, string, len, dsPtr); +#endif } char * @@ -199,11 +214,28 @@ Tcl_WinTCharToUtf( int len, Tcl_DString *dsPtr) { +#if TCL_UTF_MAX > 3 + char *p; + int size; + + if (len > 0) { + len /= 2; + } + size = WideCharToMultiByte(CP_UTF8, 0, string, len, 0, 0, NULL, NULL); + Tcl_DStringInit(dsPtr); + Tcl_DStringSetLength(dsPtr, size+1); + p = (char *)Tcl_DStringValue(dsPtr); + WideCharToMultiByte(CP_UTF8, 0, string, len, p, size, NULL, NULL); + Tcl_DStringSetLength(dsPtr, size); + p[size] = 0; + return p; +#else if (!winTCharEncoding) { winTCharEncoding = Tcl_GetEncoding(0, "unicode"); } return Tcl_ExternalToUtfDString(winTCharEncoding, string, len, dsPtr); +#endif } #if defined(TCL_WIDE_INT_IS_LONG) diff --git a/unix/tclUnixPort.h b/unix/tclUnixPort.h index ba56089..4819f10 100644 --- a/unix/tclUnixPort.h +++ b/unix/tclUnixPort.h @@ -87,8 +87,8 @@ typedef off_t Tcl_SeekOffset; typedef unsigned short WCHAR; __declspec(dllimport) extern __stdcall int GetModuleHandleExW(unsigned int, const char *, void *); __declspec(dllimport) extern __stdcall int GetModuleFileNameW(void *, const char *, int); - __declspec(dllimport) extern __stdcall int WideCharToMultiByte(int, int, const char *, int, - const char *, int, const char *, const char *); + __declspec(dllimport) extern __stdcall int WideCharToMultiByte(int, int, const void *, int, + char *, int, const char *, void *); __declspec(dllimport) extern __stdcall int MultiByteToWideChar(int, int, const char *, int, WCHAR *, int); __declspec(dllimport) extern __stdcall void OutputDebugStringW(const WCHAR *); diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c index 84c7a97..3add0d1 100644 --- a/win/tclWin32Dll.c +++ b/win/tclWin32Dll.c @@ -33,7 +33,9 @@ static int platformId; /* Running under NT, or 95/98? */ #define cpuid __asm __emit 0fh __asm __emit 0a2h #endif +#if TCL_UTF_MAX < 4 static Tcl_Encoding winTCharEncoding = NULL; +#endif /* * The following declaration is for the VC++ DLL entry point. @@ -49,7 +51,7 @@ BOOL APIENTRY DllMain(HINSTANCE hInst, DWORD reason, */ typedef struct MountPointMap { - const TCHAR *volumeName; /* Native wide string volume name. */ + TCHAR *volumeName; /* Native wide string volume name. */ TCHAR driveLetter; /* Drive letter corresponding to the volume * name. */ struct MountPointMap *nextPtr; @@ -266,7 +268,7 @@ TclWinNoBackslash( * * TclpSetInterfaces -- * - * A helper proc that initializes winTCharEncoding. + * A helper proc. * * Results: * None. @@ -280,8 +282,10 @@ TclWinNoBackslash( void TclpSetInterfaces(void) { +#if TCL_UTF_MAX < 4 TclWinResetInterfaces(); winTCharEncoding = Tcl_GetEncoding(NULL, "unicode"); +#endif } /* @@ -344,10 +348,12 @@ TclWinEncodingsCleanup(void) void TclWinResetInterfaces(void) { +#if TCL_UTF_MAX < 4 if (winTCharEncoding != NULL) { Tcl_FreeEncoding(winTCharEncoding); winTCharEncoding = NULL; } +#endif } /* @@ -532,13 +538,9 @@ TclWinDriveLetterForVolMountPoint( * (NT) or "char" strings(95). This saves you the trouble of writing the * following type of fragment over and over: * - * if (running NT) { - * encoding <- Tcl_GetEncoding("unicode"); - * nativeBuffer <- UtfToExternal(encoding, utfBuffer); - * Tcl_FreeEncoding(encoding); - * } else { - * nativeBuffer <- UtfToExternal(NULL, utfBuffer); - * } + * encoding <- Tcl_GetEncoding("unicode"); + * nativeBuffer <- UtfToExternal(encoding, utfBuffer); + * Tcl_FreeEncoding(encoding); * * By convention, in Windows a TCHAR is a character in the ANSI code page * on Windows 95, a Unicode character on Windows NT. If you plan on @@ -561,26 +563,55 @@ TclWinDriveLetterForVolMountPoint( TCHAR * Tcl_WinUtfToTChar( const char *string, /* Source string in UTF-8. */ - int len, /* Source string length in bytes, or < 0 for + int len, /* Source string length in bytes, or -1 for * strlen(). */ Tcl_DString *dsPtr) /* Uninitialized or free DString in which the * converted string is stored. */ { +#if TCL_UTF_MAX > 3 + TCHAR *wp; + int size = MultiByteToWideChar(CP_UTF8, 0, string, len, 0, 0); + + Tcl_DStringInit(dsPtr); + Tcl_DStringSetLength(dsPtr, 2*size+2); + wp = (TCHAR *)Tcl_DStringValue(dsPtr); + MultiByteToWideChar(CP_UTF8, 0, string, len, wp, size+1); + Tcl_DStringSetLength(dsPtr, 2*size); + wp[size] = 0; + return wp; +#else return (TCHAR *) Tcl_UtfToExternalDString(winTCharEncoding, string, len, dsPtr); +#endif } char * Tcl_WinTCharToUtf( - const TCHAR *string, /* Source string in Unicode when running NT, - * ANSI when running 95. */ - int len, /* Source string length in bytes, or < 0 for + const TCHAR *string, /* Source string in Unicode. */ + int len, /* Source string length in bytes, or -1 for * platform-specific string length. */ Tcl_DString *dsPtr) /* Uninitialized or free DString in which the * converted string is stored. */ { +#if TCL_UTF_MAX > 3 + char *p; + int size; + + if (len > 0) { + len /= 2; + } + size = WideCharToMultiByte(CP_UTF8, 0, string, len, 0, 0, NULL, NULL); + Tcl_DStringInit(dsPtr); + Tcl_DStringSetLength(dsPtr, size+1); + p = (char *)Tcl_DStringValue(dsPtr); + WideCharToMultiByte(CP_UTF8, 0, string, len, p, size, NULL, NULL); + Tcl_DStringSetLength(dsPtr, size); + p[size] = 0; + return p; +#else return Tcl_ExternalToUtfDString(winTCharEncoding, (const char *) string, len, dsPtr); +#endif } /* -- cgit v0.12 From 301f6bcb839b301e1e3d3a92e3713696780c95ca Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 28 Dec 2017 18:49:24 +0000 Subject: Fix handling of surrogates (when TCL_UTF_MAX > 3) in Tcl_UtfNcmp()/Tcl_UtfNcasecmp()/TclUtfCasecmp(). Backported from core-8-branch, where this was fixed already. --- generic/tclPkg.c | 6 +++--- generic/tclUtf.c | 57 ++++++++++++++++++++++++++++---------------------------- 2 files changed, 32 insertions(+), 31 deletions(-) diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 4f6faa8..6d826a9 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -414,7 +414,7 @@ PkgRequireCore( continue; } - + /* Check satisfaction of requirements before considering the current version further. */ if (reqc > 0) { satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv); @@ -424,7 +424,7 @@ PkgRequireCore( continue; } } - + if (bestPtr != NULL) { int res = CompareVersions(availVersion, bestVersion, NULL); @@ -485,7 +485,7 @@ PkgRequireCore( /* * Clean up memorized internal reps, if any. */ - + if (bestVersion != NULL) { ckfree(bestVersion); bestVersion = NULL; diff --git a/generic/tclUtf.c b/generic/tclUtf.c index c60e99e..6255a4e 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -726,8 +726,7 @@ Tcl_UniCharAtIndex( { Tcl_UniChar ch = 0; - while (index >= 0) { - index--; + while (index-- >= 0) { src += TclUtfToUniChar(src, &ch); } return ch; @@ -757,8 +756,7 @@ Tcl_UtfAtIndex( { Tcl_UniChar ch = 0; - while (index > 0) { - index--; + while (index-- > 0) { src += TclUtfToUniChar(src, &ch); } return src; @@ -1072,16 +1070,17 @@ Tcl_UtfNcmp( cs += TclUtfToUniChar(cs, &ch1); ct += TclUtfToUniChar(ct, &ch2); + if (ch1 != ch2) { #if TCL_UTF_MAX == 4 - /* map high surrogate characters to values > 0xffff */ - if ((ch1 & 0xFC00) == 0xD800) { - ch1 += 0x4000; - } - if ((ch2 & 0xFC00) == 0xD800) { - ch2 += 0x4000; - } + /* Surrogates always report higher than non-surrogates */ + if (((ch1 & 0xFC00) == 0xD800)) { + if ((ch2 & 0xFC00) != 0xD800) { + return ch1; + } + } else if ((ch2 & 0xFC00) == 0xD800) { + return -ch2; + } #endif - if (ch1 != ch2) { return (ch1 - ch2); } } @@ -1122,16 +1121,17 @@ Tcl_UtfNcasecmp( */ cs += TclUtfToUniChar(cs, &ch1); ct += TclUtfToUniChar(ct, &ch2); + if (ch1 != ch2) { #if TCL_UTF_MAX == 4 - /* map high surrogate characters to values > 0xffff */ - if ((ch1 & 0xFC00) == 0xD800) { - ch1 += 0x4000; - } - if ((ch2 & 0xFC00) == 0xD800) { - ch2 += 0x4000; - } + /* Surrogates always report higher than non-surrogates */ + if (((ch1 & 0xFC00) == 0xD800)) { + if ((ch2 & 0xFC00) != 0xD800) { + return ch1; + } + } else if ((ch2 & 0xFC00) == 0xD800) { + return -ch2; + } #endif - if (ch1 != ch2) { ch1 = Tcl_UniCharToLower(ch1); ch2 = Tcl_UniCharToLower(ch2); if (ch1 != ch2) { @@ -1170,16 +1170,17 @@ TclUtfCasecmp( while (*cs && *ct) { cs += TclUtfToUniChar(cs, &ch1); ct += TclUtfToUniChar(ct, &ch2); + if (ch1 != ch2) { #if TCL_UTF_MAX == 4 - /* map high surrogate characters to values > 0xffff */ - if ((ch1 & 0xFC00) == 0xD800) { - ch1 += 0x4000; - } - if ((ch2 & 0xFC00) == 0xD800) { - ch2 += 0x4000; - } + /* Surrogates always report higher than non-surrogates */ + if (((ch1 & 0xFC00) == 0xD800)) { + if ((ch2 & 0xFC00) != 0xD800) { + return ch1; + } + } else if ((ch2 & 0xFC00) == 0xD800) { + return -ch2; + } #endif - if (ch1 != ch2) { ch1 = Tcl_UniCharToLower(ch1); ch2 = Tcl_UniCharToLower(ch2); if (ch1 != ch2) { -- cgit v0.12 From ad43c617e3fb81c44639a400b8a6d611aa52e3f2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 28 Dec 2017 21:14:40 +0000 Subject: Fix bug introduced in [0dd0d14489258621] (only for TCL_UTF_MAX > 3): If len parameter = -1, returned size includes terminating 0-byte. So, account for that. Also, fix some comments which were not accurate any more, now that Windows 95/98 is not supported any more. --- generic/tclStubInit.c | 2 ++ win/tclWin32Dll.c | 33 ++++++++++++++++----------------- 2 files changed, 18 insertions(+), 17 deletions(-) diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 679a12b..b28d501 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -196,6 +196,7 @@ Tcl_WinUtfToTChar( Tcl_DStringSetLength(dsPtr, 2*size+2); wp = (WCHAR *)Tcl_DStringValue(dsPtr); MultiByteToWideChar(CP_UTF8, 0, string, len, wp, size+1); + if (len == -1) --size; /* account for 0-byte at string end */ Tcl_DStringSetLength(dsPtr, 2*size); wp[size] = 0; return (char *)wp; @@ -226,6 +227,7 @@ Tcl_WinTCharToUtf( Tcl_DStringSetLength(dsPtr, size+1); p = (char *)Tcl_DStringValue(dsPtr); WideCharToMultiByte(CP_UTF8, 0, string, len, p, size, NULL, NULL); + if (len == -1) --size; /* account for 0-byte at string end */ Tcl_DStringSetLength(dsPtr, size); p[size] = 0; return p; diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c index 3add0d1..6c973df 100644 --- a/win/tclWin32Dll.c +++ b/win/tclWin32Dll.c @@ -519,35 +519,32 @@ TclWinDriveLetterForVolMountPoint( * * Tcl_WinUtfToTChar, Tcl_WinTCharToUtf -- * - * Convert between UTF-8 and Unicode when running Windows NT or the - * current ANSI code page when running Windows 95. + * Convert between UTF-8 and Unicode when running Windows. * - * On Mac, Unix, and Windows 95, all strings exchanged between Tcl and - * the OS are "char" oriented. We need only one Tcl_Encoding to convert - * between UTF-8 and the system's native encoding. We use NULL to - * represent that encoding. + * On Mac and Unix, all strings exchanged between Tcl and the OS are + * "char" oriented. We need only one Tcl_Encoding to convert between + * UTF-8 and the system's native encoding. We use NULL to represent + * that encoding. * - * On NT, some strings exchanged between Tcl and the OS are "char" + * On Windows, some strings exchanged between Tcl and the OS are "char" * oriented, while others are in Unicode. We need two Tcl_Encoding APIs * depending on whether we are targeting a "char" or Unicode interface. * - * Calling Tcl_UtfToExternal() or Tcl_ExternalToUtf() with an encoding of - * NULL should always used to convert between UTF-8 and the system's + * Calling Tcl_UtfToExternal() or Tcl_ExternalToUtf() with an encoding + * of NULL should always used to convert between UTF-8 and the system's * "char" oriented encoding. The following two functions are used in - * Windows-specific code to convert between UTF-8 and Unicode strings - * (NT) or "char" strings(95). This saves you the trouble of writing the + * Windows-specific code to convert between UTF-8 and Unicode strings. + * This saves you the trouble of writing the * following type of fragment over and over: * * encoding <- Tcl_GetEncoding("unicode"); * nativeBuffer <- UtfToExternal(encoding, utfBuffer); * Tcl_FreeEncoding(encoding); * - * By convention, in Windows a TCHAR is a character in the ANSI code page - * on Windows 95, a Unicode character on Windows NT. If you plan on - * targeting a Unicode interfaces when running on NT and a "char" - * oriented interface while running on 95, these functions should be - * used. If you plan on targetting the same "char" oriented function on - * both 95 and NT, use Tcl_UtfToExternal() with an encoding of NULL. + * By convention, in Windows a TCHAR is a Unicode character. If you plan + * on targeting a Unicode interface when running on Windows, these + * functions should be used. If you plan on targetting a "char" oriented + * function on Windows, use Tcl_UtfToExternal() with an encoding of NULL. * * Results: * The result is a pointer to the string in the desired target encoding. @@ -576,6 +573,7 @@ Tcl_WinUtfToTChar( Tcl_DStringSetLength(dsPtr, 2*size+2); wp = (TCHAR *)Tcl_DStringValue(dsPtr); MultiByteToWideChar(CP_UTF8, 0, string, len, wp, size+1); + if (len == -1) --size; /* account for 0-byte at string end */ Tcl_DStringSetLength(dsPtr, 2*size); wp[size] = 0; return wp; @@ -605,6 +603,7 @@ Tcl_WinTCharToUtf( Tcl_DStringSetLength(dsPtr, size+1); p = (char *)Tcl_DStringValue(dsPtr); WideCharToMultiByte(CP_UTF8, 0, string, len, p, size, NULL, NULL); + if (len == -1) --size; /* account for 0-byte at string end */ Tcl_DStringSetLength(dsPtr, size); p[size] = 0; return p; -- cgit v0.12 From 6c799d891d69e04b9e0f32ca59719b4b23dc311a Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 4 Jan 2018 02:32:46 +0000 Subject: Minimal fixes to stop the [package files] machinery writing to freed mem. This contribution needs a careful review from someone who actually knows how Tcl_Preserve, etc. work. --- generic/tclPkg.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/generic/tclPkg.c b/generic/tclPkg.c index cdf9a8b..288d5dc 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -948,6 +948,7 @@ Tcl_PackageObjCmd( Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC); if (availPtr->pkgIndex) { Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC); + availPtr->pkgIndex = NULL; } ckfree(availPtr); } @@ -1001,6 +1002,7 @@ Tcl_PackageObjCmd( Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC); if (availPtr->pkgIndex) { Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC); + availPtr->pkgIndex = NULL; } break; } @@ -1012,7 +1014,7 @@ Tcl_PackageObjCmd( } if (availPtr == NULL) { availPtr = ckalloc(sizeof(PkgAvail)); - availPtr->pkgIndex = 0; + availPtr->pkgIndex = NULL; DupBlock(availPtr->version, argv3, (unsigned) length + 1); if (prevPtr == NULL) { @@ -1384,6 +1386,7 @@ TclFreePackageInfo( Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC); if (availPtr->pkgIndex) { Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC); + availPtr->pkgIndex = NULL; } ckfree(availPtr); } -- cgit v0.12 From 26b5bf3eca7b04ccab8b69c78ffd578425e8f6f0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 4 Jan 2018 12:58:31 +0000 Subject: (cherry-pick): Use http 2 instead of http 1 for Safe Base testing. --- tests/safe.test | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/tests/safe.test b/tests/safe.test index 6784bb9..5bed5ff 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -172,17 +172,17 @@ test safe-6.3 {test safe interpreters knowledge of the world} { # aren't leaking infos, but they still do... # high level general test -test safe-7.1 {tests that everything works at high level} { +test safe-7.1 {tests that everything works at high level} -body { set i [safe::interpCreate]; # no error shall occur: # (because the default access_path shall include 1st level sub dirs # so package require in a slave works like in the master) - set v [interp eval $i {package require http 1}] + set v [interp eval $i {package require http 2}] # no error shall occur: - interp eval $i {http_config}; + interp eval $i {http::config} safe::interpDelete $i set v -} 1.0 +} -match glob -result 2.* test safe-7.2 {tests specific path and interpFind/AddToAccessPath} -body { set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]; # should not add anything (p0) -- cgit v0.12 From 7e4261e22c5e89d5591793bf264bdc35eb154653 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Mon, 8 Jan 2018 17:03:07 +0000 Subject: Rearrange a few lines TclRenameCommand to reduce operations. --- generic/tclBasic.c | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 3ed3447..d2e96b8 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -2626,10 +2626,6 @@ TclRenameCommand( Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", oldName, NULL); return TCL_ERROR; } - cmdNsPtr = cmdPtr->nsPtr; - oldFullName = Tcl_NewObj(); - Tcl_IncrRefCount(oldFullName); - Tcl_GetCommandFullName(interp, cmd, oldFullName); /* * If the new command name is NULL or empty, delete the command. Do this @@ -2638,10 +2634,14 @@ TclRenameCommand( if ((newName == NULL) || (*newName == '\0')) { Tcl_DeleteCommandFromToken(interp, cmd); - result = TCL_OK; - goto done; + return TCL_OK; } + cmdNsPtr = cmdPtr->nsPtr; + oldFullName = Tcl_NewObj(); + Tcl_IncrRefCount(oldFullName); + Tcl_GetCommandFullName(interp, cmd, oldFullName); + /* * Make sure that the destination command does not already exist. The * rename operation is like creating a command, so we should automatically -- cgit v0.12 From 4a5058fc1bd50653d1de1db7f43ed983b4c8fd72 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Mon, 8 Jan 2018 18:21:40 +0000 Subject: Udate Tcl_ObjectDeleted to reflect recent changes. --- generic/tclOO.c | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 0243c15..7719f50 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -1083,9 +1083,7 @@ ObjectNamespaceDeleted( * methods on the object. */ - /* To do: Get dkf to weigh in on wether this should be protected with a - * !IsRoot() condition. - */ + /* To do: Should this be protected with a * !IsRoot() condition? */ TclOORemoveFromInstances(oPtr, oPtr->selfCls); FOREACH(mixinPtr, oPtr->mixins) { @@ -2842,7 +2840,7 @@ int Tcl_ObjectDeleted( Tcl_Object object) { - return Deleted((Object *)object) ? 1 : 0; + return ((Object *)object)->command == NULL; } Tcl_Object -- cgit v0.12 From 6d9902632c27a3a3a46f9ea9506555027acac8ac Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 9 Jan 2018 00:10:22 +0000 Subject: Some refactoring and tidying up of comments. --- generic/tclOO.c | 340 ++++++++++++++++++++++++++++++---------------- generic/tclOOCall.c | 13 +- generic/tclOODefineCmds.c | 95 +++++++++++-- 3 files changed, 318 insertions(+), 130 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 7719f50..39e3fb2 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -71,7 +71,9 @@ static void DeletedHelpersNamespace(ClientData clientData); static Tcl_NRPostProc FinalizeAlloc; static Tcl_NRPostProc FinalizeNext; static Tcl_NRPostProc FinalizeObjectCall; -static void initClassPath(Tcl_Interp * interp, Class *clsPtr); +static inline void InitClassPath(Tcl_Interp * interp, Class *clsPtr); +static void InitClassSystemRoots(Tcl_Interp *interp, + Foundation *fPtr); static int InitFoundation(Tcl_Interp *interp); static void KillFoundation(ClientData clientData, Tcl_Interp *interp); @@ -82,6 +84,8 @@ static void ObjectRenamedTrace(ClientData clientData, const char *newName, int flags); static void ReleaseClassContents(Tcl_Interp *interp,Object *oPtr); static void DeleteDescendants(Tcl_Interp *interp,Object *oPtr); +static inline void RemoveClass(Class **list, int num, int idx); +static inline void RemoveObject(Object **list, int num, int idx); static inline void SquelchCachedName(Object *oPtr); static int PublicObjectCmd(ClientData clientData, @@ -96,8 +100,6 @@ static int PrivateObjectCmd(ClientData clientData, static int PrivateNRObjectCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -static void RemoveClass(Class ** list, int num, int idx); -static void RemoveObject(Object ** list, int num, int idx); /* * Methods in the oo::object and oo::class classes. First, we define a helper @@ -236,14 +238,50 @@ MODULE_SCOPE const TclOOStubs tclOOStubs; #define IsRoot(ocPtr) ((ocPtr)->flags & (ROOT_OBJECT|ROOT_CLASS)) #define RemoveItem(type, lst, i) \ - do { \ - Remove ## type ((lst).list, (lst).num, i); \ - (lst).num--; \ + do { \ + Remove ## type ((lst).list, (lst).num, i); \ + (lst).num--; \ } while (0) /* * ---------------------------------------------------------------------- * + * RemoveClass, RemoveObject -- + * + * Helpers for the RemoveItem macro for deleting a class or object from a + * list. Setting the "empty" location to NULL makes debugging a little + * easier. + * + * ---------------------------------------------------------------------- + */ + +static inline void +RemoveClass( + Class **list, + int num, + int idx) +{ + for (; idx < num - 1; idx++) { + list[idx] = list[idx + 1]; + } + list[idx] = NULL; +} + +static inline void +RemoveObject( + Object **list, + int num, + int idx) +{ + for (; idx < num - 1; idx++) { + list[idx] = list[idx + 1]; + } + list[idx] = NULL; +} + +/* + * ---------------------------------------------------------------------- + * * TclOOInit -- * * Called to initialise the OO system within an interpreter. @@ -321,10 +359,6 @@ InitFoundation( Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData)); Foundation *fPtr = ckalloc(sizeof(Foundation)); Tcl_Obj *namePtr, *argsPtr, *bodyPtr; - - Class fakeCls; - Object fakeObject; - Tcl_DString buffer; Command *cmdPtr; int i; @@ -387,47 +421,10 @@ InitFoundation( Tcl_CallWhenDeleted(interp, KillFoundation, NULL); /* - * Create the objects at the core of the object system. These need to be - * spliced manually. + * Create the special objects at the core of the object system. */ - /* Stand up a phony class for bootstrapping. */ - fPtr->objectCls = &fakeCls; - /* referenced in AllocClass to increment the refCount. */ - fakeCls.thisPtr = &fakeObject; - - fPtr->objectCls = AllocClass(interp, - AllocObject(interp, "object", (Namespace *)fPtr->ooNs, NULL)); - fPtr->classCls = AllocClass(interp, - AllocObject(interp, "class", (Namespace *)fPtr->ooNs, NULL)); - - /* Rewire bootstrapped objects. */ - fPtr->objectCls->thisPtr->selfCls = fPtr->classCls; - fPtr->classCls->thisPtr->selfCls = fPtr->classCls; - - AddRef(fPtr->objectCls->thisPtr); - AddRef(fPtr->classCls->thisPtr); - AddRef(fPtr->classCls->thisPtr->selfCls->thisPtr); - AddRef(fPtr->objectCls->thisPtr->selfCls->thisPtr); - - /* special initialization for the primordial objects */ - fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT; - fPtr->objectCls->flags |= ROOT_OBJECT; - - /* This is why it is unnecessary in this routine to make up for the - * incremented reference count of fPtr->objectCls that was sallwed by - * fakeObject. */ - fPtr->objectCls->superclasses.num = 0; - ckfree(fPtr->objectCls->superclasses.list); - fPtr->objectCls->superclasses.list = NULL; - - fPtr->classCls->thisPtr->flags |= ROOT_CLASS; - fPtr->classCls->flags |= ROOT_CLASS; - - /* Standard initialization for new Objects */ - TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls); - TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls); - TclOOAddToSubclasses(fPtr->classCls, fPtr->objectCls); + InitClassSystemRoots(interp, fPtr); /* * Basic method declarations for the core classes. @@ -494,6 +491,88 @@ InitFoundation( } return Tcl_EvalEx(interp, slotScript, -1, 0); } + +/* + * ---------------------------------------------------------------------- + * + * InitClassSystemRoots -- + * + * Creates the objects at the core of the object system. These need to be + * spliced manually. + * + * ---------------------------------------------------------------------- + */ + +static void +InitClassSystemRoots( + Tcl_Interp *interp, + Foundation *fPtr) +{ + Class fakeCls; + Object fakeObject; + + /* + * Stand up a phony class for bootstrapping. + */ + + fPtr->objectCls = &fakeCls; + + /* + * Referenced in AllocClass to increment the refCount. + */ + + fakeCls.thisPtr = &fakeObject; + + fPtr->objectCls = AllocClass(interp, + AllocObject(interp, "object", (Namespace *)fPtr->ooNs, NULL)); + fPtr->classCls = AllocClass(interp, + AllocObject(interp, "class", (Namespace *)fPtr->ooNs, NULL)); + + /* + * Rewire bootstrapped objects. + */ + + fPtr->objectCls->thisPtr->selfCls = fPtr->classCls; + fPtr->classCls->thisPtr->selfCls = fPtr->classCls; + + AddRef(fPtr->objectCls->thisPtr); + AddRef(fPtr->classCls->thisPtr); + AddRef(fPtr->classCls->thisPtr->selfCls->thisPtr); + AddRef(fPtr->objectCls->thisPtr->selfCls->thisPtr); + + /* + * Special initialization for the primordial objects. + */ + + fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT; + fPtr->objectCls->flags |= ROOT_OBJECT; + + /* + * This is why it is unnecessary in this routine to make up for the + * incremented reference count of fPtr->objectCls that was sallwed by + * fakeObject. + */ + + fPtr->objectCls->superclasses.num = 0; + ckfree(fPtr->objectCls->superclasses.list); + fPtr->objectCls->superclasses.list = NULL; + + fPtr->classCls->thisPtr->flags |= ROOT_CLASS; + fPtr->classCls->flags |= ROOT_CLASS; + + /* + * Standard initialization for new Objects. + */ + + TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls); + TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls); + TclOOAddToSubclasses(fPtr->classCls, fPtr->objectCls); + + /* + * THIS IS THE ONLY FUNCTION THAT DOES NON-STANDARD CLASS SPLICING. + * Everything else is careful to prohibit looping. + */ +} /* * ---------------------------------------------------------------------- @@ -584,8 +663,8 @@ AllocObject( * if the OO system should pick the object * name itself (equal to the namespace * name). */ - Namespace *nsPtr, /* The namespace to create the object in, - or NULL if *nameStr is NULL */ + Namespace *nsPtr, /* The namespace to create the object in, or + * NULL if *nameStr is NULL */ const char *nsNameStr) /* The name of the namespace to create, or * NULL if the OO system should pick a unique * name itself. If this is non-NULL but names @@ -678,10 +757,10 @@ AllocObject( /* * An object starts life with a refCount of 2 to mark the two stages of * destruction it occur: A call to ObjectRenamedTrace(), and a call to - * ObjectNamespaceDeleted(). + * ObjectNamespaceDeleted(). */ - oPtr->refCount = 2; + oPtr->refCount = 2; oPtr->flags = USE_CLASS_CACHE; /* @@ -716,7 +795,7 @@ AllocObject( tracePtr->refCount = 1; oPtr->myCommand = TclNRCreateCommandInNs(interp, "my", oPtr->namespacePtr, - PrivateObjectCmd, PrivateNRObjectCmd, oPtr, MyDeleted); + PrivateObjectCmd, PrivateNRObjectCmd, oPtr, MyDeleted); return oPtr; } @@ -786,6 +865,7 @@ ObjectRenamedTrace( int flags) /* Why was the object deleted? */ { Object *oPtr = clientData; + /* * If this is a rename and not a delete of the object, we just flush the * cache of the object name. @@ -812,7 +892,7 @@ ObjectRenamedTrace( /* * ---------------------------------------------------------------------- * - * ReleaseClassContents -- + * DeleteDescendants, ReleaseClassContents -- * * Tear down the special class data structure, including deleting all * dependent classes and objects. @@ -834,9 +914,11 @@ DeleteDescendants( */ FOREACH(mixinSubclassPtr, clsPtr->mixinSubs) { - /* This condition also covers the case where mixinSubclassPtr == + /* + * This condition also covers the case where mixinSubclassPtr == * clsPtr */ + if (!Deleted(mixinSubclassPtr->thisPtr)) { Tcl_DeleteCommandFromToken(interp, mixinSubclassPtr->thisPtr->command); @@ -844,6 +926,7 @@ DeleteDescendants( i -= TclOORemoveFromMixinSubs(mixinSubclassPtr, clsPtr); TclOODecrRefCount(mixinSubclassPtr->thisPtr); } + /* * Squelch subclasses of this class. */ @@ -862,7 +945,10 @@ DeleteDescendants( if (!IsRootClass(oPtr)) { FOREACH(instancePtr, clsPtr->instances) { - /* This condition also covers the case where instancePtr == oPtr */ + /* + * This condition also covers the case where instancePtr == oPtr + */ + if (!Deleted(instancePtr) && !IsRoot(instancePtr)) { Tcl_DeleteCommandFromToken(interp, instancePtr->command); } @@ -870,7 +956,6 @@ DeleteDescendants( } } } - static void ReleaseClassContents( @@ -878,7 +963,7 @@ ReleaseClassContents( Object *oPtr) /* The object representing the class. */ { FOREACH_HASH_DECLS; - int i; + int i; Class *clsPtr = oPtr->classPtr, *tmpClsPtr; Method *mPtr; Foundation *fPtr = oPtr->fPtr; @@ -1008,9 +1093,11 @@ ObjectNamespaceDeleted( int i; if (Deleted(oPtr)) { - /* To do: Can ObjectNamespaceDeleted ever be called twice? If not, - * this guard could be removed. + /* + * TODO: Can ObjectNamespaceDeleted ever be called twice? If not, this + * guard could be removed. */ + return; } @@ -1019,6 +1106,7 @@ ObjectNamespaceDeleted( * process of being deleted, nothing else may modify its bookeeping * records. This is the flag that */ + oPtr->flags |= OBJECT_DELETED; /* Let the dominoes fall */ @@ -1032,6 +1120,7 @@ ObjectNamespaceDeleted( * in that case when the destructor is partially deleted before the uses * of it have gone. [Bug 2949397] */ + if (!Tcl_InterpDeleted(interp) && !(oPtr->flags & DESTRUCTOR_CALLED)) { CallContext *contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL); @@ -1071,6 +1160,7 @@ ObjectNamespaceDeleted( * The namespace must have been deleted directly. Delete the command * as well. */ + Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command); } @@ -1083,7 +1173,10 @@ ObjectNamespaceDeleted( * methods on the object. */ - /* To do: Should this be protected with a * !IsRoot() condition? */ + /* + * TODO: Should this be protected with a * !IsRoot() condition? + */ + TclOORemoveFromInstances(oPtr, oPtr->selfCls); FOREACH(mixinPtr, oPtr->mixins) { @@ -1134,22 +1227,19 @@ ObjectNamespaceDeleted( } /* - * Because an object can be a class that is an instance of itself, the - * A class object's class structure should only be cleaned after most of - * the cleanup on the object is done. - */ - - - /* + * Because an object can be a class that is an instance of itself, the + * class object's class structure should only be cleaned after most of the + * cleanup on the object is done. + * * The class of objects needs some special care; if it is deleted (and * we're not killing the whole interpreter) we force the delete of the * class of classes now as well. Due to the incestuous nature of those two * classes, if one goes the other must too and yet the tangle can * sometimes not go away automatically; we force it here. [Bug 2962664] */ - if (IsRootObject(oPtr) && !Deleted(fPtr->classCls->thisPtr) - && !Tcl_InterpDeleted(interp)) { + if (IsRootObject(oPtr) && !Deleted(fPtr->classCls->thisPtr) + && !Tcl_InterpDeleted(interp)) { Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command); } @@ -1170,7 +1260,7 @@ ObjectNamespaceDeleted( /* * ---------------------------------------------------------------------- * - * TclOODecrRef -- + * TclOODecrRefCount -- * * Decrement the refcount of an object and deallocate storage then object * is no longer referenced. Returns 1 if storage was deallocated, and 0 @@ -1178,9 +1268,14 @@ ObjectNamespaceDeleted( * * ---------------------------------------------------------------------- */ -int TclOODecrRefCount(Object *oPtr) { + +int +TclOODecrRefCount( + Object *oPtr) +{ if (oPtr->refCount-- <= 1) { Class *clsPtr = oPtr->classPtr; + if (oPtr->classPtr != NULL) { ckfree(clsPtr->superclasses.list); ckfree(clsPtr->subclasses.list); @@ -1195,18 +1290,6 @@ int TclOODecrRefCount(Object *oPtr) { return 0; } -/* setting the "empty" location to NULL makes debugging a little easier */ -#define REMOVEBODY { \ - for (; idx < num - 1; idx++) { \ - list[idx] = list[idx+1]; \ - } \ - list[idx] = NULL; \ - return; \ -} -void RemoveClass(Class **list, int num, int idx) REMOVEBODY - -void RemoveObject(Object **list, int num, int idx) REMOVEBODY - /* * ---------------------------------------------------------------------- * @@ -1226,6 +1309,7 @@ TclOORemoveFromInstances( { int i, res = 0; Object *instPtr; + if (Deleted(clsPtr->thisPtr)) { return res; } @@ -1291,6 +1375,7 @@ TclOORemoveFromSubclasses( { int i, res = 0; Class *subclsPtr; + if (Deleted(superPtr->thisPtr)) { return res; } @@ -1331,7 +1416,8 @@ TclOOAddToSubclasses( if (superPtr->subclasses.size == ALLOC_CHUNK) { superPtr->subclasses.list = ckalloc(sizeof(Class *) * ALLOC_CHUNK); } else { - superPtr->subclasses.list = ckrealloc(superPtr->subclasses.list, sizeof(Class *) * superPtr->subclasses.size); + superPtr->subclasses.list = ckrealloc(superPtr->subclasses.list, + sizeof(Class *) * superPtr->subclasses.size); } } superPtr->subclasses.list[superPtr->subclasses.num++] = subPtr; @@ -1418,6 +1504,25 @@ TclOOAddToMixinSubs( * ---------------------------------------------------------------------- */ +static inline void +InitClassPath( + Tcl_Interp *interp, + Class *clsPtr) +{ + Foundation *fPtr = GetFoundation(interp); + + if (fPtr->helpersNs != NULL) { + Tcl_Namespace *path[2]; + + path[0] = fPtr->helpersNs; + path[1] = fPtr->ooNs; + TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 2, path); + } else { + TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 1, + &fPtr->ooNs); + } +} + static Class * AllocClass( Tcl_Interp *interp, /* Interpreter within which to allocate the @@ -1434,7 +1539,8 @@ AllocClass( /* * Configure the namespace path for the class's object. */ - initClassPath(interp, clsPtr); + + InitClassPath(interp, clsPtr); /* * Classes are subclasses of oo::object, i.e. the objects they create are @@ -1460,19 +1566,6 @@ AllocClass( Tcl_InitObjHashTable(&clsPtr->classMethods); return clsPtr; } -static void -initClassPath(Tcl_Interp *interp, Class *clsPtr) { - Foundation *fPtr = GetFoundation(interp); - if (fPtr->helpersNs != NULL) { - Tcl_Namespace *path[2]; - path[0] = fPtr->helpersNs; - path[1] = fPtr->ooNs; - TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 2, path); - } else { - TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 1, - &fPtr->ooNs); - } -} /* * ---------------------------------------------------------------------- @@ -1503,7 +1596,9 @@ Tcl_NewObjectInstance( ClientData clientData[4]; oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr); - if (oPtr == NULL) {return NULL;} + if (oPtr == NULL) { + return NULL; + } /* * Run constructors, except when objc < 0, which is a special flag case @@ -1572,7 +1667,9 @@ TclNRNewObjectInstance( Object *oPtr; oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr); - if (oPtr == NULL) {return TCL_ERROR;} + if (oPtr == NULL) { + return TCL_ERROR; + } /* * Run constructors, except when objc < 0 (a special flag case used for @@ -1623,29 +1720,33 @@ TclNewObjectInstanceCommon( Foundation *fPtr = GetFoundation(interp); Object *oPtr; const char *simpleName = NULL; - Namespace *nsPtr = NULL, *dummy, - *inNsPtr = (Namespace *)TclGetCurrentNamespace(interp); + Namespace *nsPtr = NULL, *dummy; + Namespace *inNsPtr = (Namespace *) TclGetCurrentNamespace(interp); int isNew; if (nameStr) { - TclGetNamespaceForQualName(interp, nameStr, inNsPtr, TCL_CREATE_NS_IF_UNKNOWN, - &nsPtr, &dummy, &dummy, &simpleName); + TclGetNamespaceForQualName(interp, nameStr, inNsPtr, + TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy, &dummy, &simpleName); /* * Disallow creation of an object over an existing command. */ hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, simpleName, &isNew); - if (isNew) { - /* Just kidding */ - Tcl_DeleteHashEntry(hPtr); - } else { + if (!isNew) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create object \"%s\": command already exists with" " that name", nameStr)); Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL); return NULL; } + + /* + * We could make a hash entry! Don't actually want to do that here so + * nuke it immediately because we'll create it properly soon. + */ + + Tcl_DeleteHashEntry(hPtr); } /* @@ -1655,6 +1756,7 @@ TclNewObjectInstanceCommon( oPtr = AllocObject(interp, simpleName, nsPtr, nsNameStr); oPtr->selfCls = classPtr; TclOOAddToInstances(oPtr, classPtr); + /* * Check to see if we're really creating a class. If so, allocate the * class structure as well. @@ -1690,8 +1792,8 @@ FinalizeAlloc( Tcl_Object *objectPtr = data[3]; /* - * Ensure an error if the object was deleted in the constructor. - * Don't want to lose errors by accident. [Bug 2903011] + * Ensure an error if the object was deleted in the constructor. Don't + * want to lose errors by accident. [Bug 2903011] */ if (result != TCL_ERROR && Deleted(oPtr)) { @@ -1713,13 +1815,21 @@ FinalizeAlloc( (void) TclOOObjectName(interp, oPtr); Tcl_DeleteCommandFromToken(interp, oPtr->command); } - /* This decrements the refcount of oPtr */ + + /* + * This decrements the refcount of oPtr. + */ + TclOODeleteContext(contextPtr); return TCL_ERROR; } Tcl_RestoreInterpState(interp, state); *objectPtr = (Tcl_Object) oPtr; - /* This decrements the refcount of oPtr */ + + /* + * This decrements the refcount of oPtr. + */ + TclOODeleteContext(contextPtr); return TCL_OK; } @@ -1828,7 +1938,7 @@ Tcl_CopyObjectInstance( */ o2Ptr->flags = oPtr->flags & ~( - OBJECT_DELETED | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING); + OBJECT_DELETED | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING); /* * Copy the object's metadata. */ diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index c71425b..7da9da0 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -110,7 +110,11 @@ TclOODeleteContext( TclOODeleteChain(contextPtr->callPtr); if (oPtr != NULL) { TclStackFree(oPtr->fPtr->interp, contextPtr); - /* Corresponding AddRef() in TclOO.c/TclOOObjectCmdCore */ + + /* + * Corresponding AddRef() in TclOO.c/TclOOObjectCmdCore + */ + TclOODecrRefCount(oPtr); } } @@ -901,6 +905,7 @@ InitCallChain( * ---------------------------------------------------------------------- * * IsStillValid -- + * * Calculates whether the given call chain can be used for executing a * method for the given object. The condition on a chain from a cached * location being reusable is: @@ -1172,7 +1177,11 @@ TclOOGetCallContext( returnContext: contextPtr = TclStackAlloc(oPtr->fPtr->interp, sizeof(CallContext)); contextPtr->oPtr = oPtr; - /* Corresponding TclOODecrRefCount() in TclOODeleteContext */ + + /* + * Corresponding TclOODecrRefCount() in TclOODeleteContext + */ + AddRef(oPtr); contextPtr->callPtr = callPtr; contextPtr->skip = 2; diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 7f3ea18..c08b350 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -123,6 +123,7 @@ static const struct DeclaredSlot slots[] = { * ---------------------------------------------------------------------- * * BumpGlobalEpoch -- + * * Utility that ensures that call chains that are invalid will get thrown * away at an appropriate time. Note that exactly which epoch gets * advanced will depend on exactly what the class is tangled up in; in @@ -167,6 +168,7 @@ BumpGlobalEpoch( * ---------------------------------------------------------------------- * * RecomputeClassCacheFlag -- + * * Determine whether the object is prototypical of its class, and hence * able to use the class's method chain cache. * @@ -189,6 +191,7 @@ RecomputeClassCacheFlag( * ---------------------------------------------------------------------- * * TclOOObjectSetFilters -- + * * Install a list of filter method names into an object. * * ---------------------------------------------------------------------- @@ -247,6 +250,7 @@ TclOOObjectSetFilters( * ---------------------------------------------------------------------- * * TclOOClassSetFilters -- + * * Install a list of filter method names into a class. * * ---------------------------------------------------------------------- @@ -309,6 +313,7 @@ TclOOClassSetFilters( * ---------------------------------------------------------------------- * * TclOOObjectSetMixins -- + * * Install a list of mixin classes into an object. * * ---------------------------------------------------------------------- @@ -350,9 +355,12 @@ TclOOObjectSetMixins( FOREACH(mixinPtr, oPtr->mixins) { if (mixinPtr != oPtr->selfCls) { TclOOAddToInstances(oPtr, mixinPtr); - /* Corresponding TclOODecrRefCount() is in the caller of this + + /* + * Corresponding TclOODecrRefCount() is in the caller of this * function. */ + TclOODecrRefCount(mixinPtr->thisPtr); } } @@ -364,6 +372,7 @@ TclOOObjectSetMixins( * ---------------------------------------------------------------------- * * TclOOClassSetMixins -- + * * Install a list of mixin classes into a class. * * ---------------------------------------------------------------------- @@ -401,9 +410,12 @@ TclOOClassSetMixins( memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins); FOREACH(mixinPtr, classPtr->mixins) { TclOOAddToMixinSubs(classPtr, mixinPtr); - /* Corresponding TclOODecrRefCount() is in the caller of this - * function + + /* + * Corresponding TclOODecrRefCount() is in the caller of this + * function. */ + TclOODecrRefCount(mixinPtr->thisPtr); } } @@ -414,6 +426,7 @@ TclOOClassSetMixins( * ---------------------------------------------------------------------- * * RenameDeleteMethod -- + * * Core of the code to rename and delete methods. * * ---------------------------------------------------------------------- @@ -503,6 +516,7 @@ RenameDeleteMethod( * ---------------------------------------------------------------------- * * TclOOUnknownDefinition -- + * * Handles what happens when an unknown command is encountered during the * processing of a definition script. Works by finding a command in the * operating definition namespace that the requested command is a unique @@ -581,6 +595,7 @@ TclOOUnknownDefinition( * ---------------------------------------------------------------------- * * FindCommand -- + * * Specialized version of Tcl_FindCommand that handles command prefixes * and disallows namespace magic. * @@ -641,6 +656,7 @@ FindCommand( * ---------------------------------------------------------------------- * * InitDefineContext -- + * * Does the magic incantations necessary to push the special stack frame * used when processing object definitions. It is up to the caller to * dispose of the frame (with TclPopStackFrame) when finished. @@ -666,7 +682,9 @@ InitDefineContext( return TCL_ERROR; } - /* framePtrPtr is needed to satisfy GCC 3.3's strict aliasing rules */ + /* + * framePtrPtr is needed to satisfy GCC 3.3's strict aliasing rules. + */ (void) TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, namespacePtr, FRAME_IS_OO_DEFINE); @@ -681,6 +699,7 @@ InitDefineContext( * ---------------------------------------------------------------------- * * TclOOGetDefineCmdContext -- + * * Extracts the magic token from the current stack frame, or returns NULL * (and leaves an error message) otherwise. * @@ -717,6 +736,7 @@ TclOOGetDefineCmdContext( * ---------------------------------------------------------------------- * * GetClassInOuterContext -- + * * Wrapper round Tcl_GetObjectFromObj to perform the lookup in the * context that called oo::define (or equivalent). Note that this may * have to go up multiple levels to get the level that we started doing @@ -759,6 +779,7 @@ GetClassInOuterContext( * ---------------------------------------------------------------------- * * GenerateErrorInfo -- + * * Factored out code to generate part of the error trace messages. * * ---------------------------------------------------------------------- @@ -797,6 +818,7 @@ GenerateErrorInfo( * ---------------------------------------------------------------------- * * MagicDefinitionInvoke -- + * * Part of the implementation of the "oo::define" and "oo::objdefine" * commands that is used to implement the more-than-one-argument case, * applying ensemble-like tricks with dispatch so that error messages are @@ -860,6 +882,7 @@ MagicDefinitionInvoke( * ---------------------------------------------------------------------- * * TclOODefineObjCmd -- + * * Implementation of the "oo::define" command. Works by effectively doing * the same as 'namespace eval', but with extra magic applied so that the * object to be modified is known to the commands in the target @@ -934,6 +957,7 @@ TclOODefineObjCmd( * ---------------------------------------------------------------------- * * TclOOObjDefObjCmd -- + * * Implementation of the "oo::objdefine" command. Works by effectively * doing the same as 'namespace eval', but with extra magic applied so * that the object to be modified is known to the commands in the target @@ -1001,6 +1025,7 @@ TclOOObjDefObjCmd( * ---------------------------------------------------------------------- * * TclOODefineSelfObjCmd -- + * * Implementation of the "self" subcommand of the "oo::define" command. * Works by effectively doing the same as 'namespace eval', but with * extra magic applied so that the object to be modified is known to the @@ -1068,6 +1093,7 @@ TclOODefineSelfObjCmd( * ---------------------------------------------------------------------- * * TclOODefineObjSelfObjCmd -- + * * Implementation of the "self" subcommand of the "oo::objdefine" * command. * @@ -1101,6 +1127,7 @@ TclOODefineObjSelfObjCmd( * ---------------------------------------------------------------------- * * TclOODefineClassObjCmd -- + * * Implementation of the "class" subcommand of the "oo::objdefine" * command. * @@ -1175,7 +1202,10 @@ TclOODefineClassObjCmd( if (oPtr->selfCls != clsPtr) { TclOORemoveFromInstances(oPtr, oPtr->selfCls); - /* Reference count already incremented 3 lines up. */ + /* + * Reference count already incremented a few lines up. + */ + oPtr->selfCls = clsPtr; TclOOAddToInstances(oPtr, oPtr->selfCls); @@ -1192,6 +1222,7 @@ TclOODefineClassObjCmd( * ---------------------------------------------------------------------- * * TclOODefineConstructorObjCmd -- + * * Implementation of the "constructor" subcommand of the "oo::define" * command. * @@ -1260,6 +1291,7 @@ TclOODefineConstructorObjCmd( * ---------------------------------------------------------------------- * * TclOODefineDeleteMethodObjCmd -- + * * Implementation of the "deletemethod" subcommand of the "oo::define" * and "oo::objdefine" commands. * @@ -1316,6 +1348,7 @@ TclOODefineDeleteMethodObjCmd( * ---------------------------------------------------------------------- * * TclOODefineDestructorObjCmd -- + * * Implementation of the "destructor" subcommand of the "oo::define" * command. * @@ -1380,6 +1413,7 @@ TclOODefineDestructorObjCmd( * ---------------------------------------------------------------------- * * TclOODefineExportObjCmd -- + * * Implementation of the "export" subcommand of the "oo::define" and * "oo::objdefine" commands. * @@ -1474,6 +1508,7 @@ TclOODefineExportObjCmd( * ---------------------------------------------------------------------- * * TclOODefineForwardObjCmd -- + * * Implementation of the "forward" subcommand of the "oo::define" and * "oo::objdefine" commands. * @@ -1534,6 +1569,7 @@ TclOODefineForwardObjCmd( * ---------------------------------------------------------------------- * * TclOODefineMethodObjCmd -- + * * Implementation of the "method" subcommand of the "oo::define" and * "oo::objdefine" commands. * @@ -1591,6 +1627,7 @@ TclOODefineMethodObjCmd( * ---------------------------------------------------------------------- * * TclOODefineMixinObjCmd -- + * * Implementation of the "mixin" subcommand of the "oo::define" and * "oo::objdefine" commands. * @@ -1634,9 +1671,12 @@ TclOODefineMixinObjCmd( goto freeAndError; } mixins[i-1] = clsPtr; - /* Corresponding TclOODecrRefCount() is in TclOOObjectSetMixins, + + /* + * Corresponding TclOODecrRefCount() is in TclOOObjectSetMixins, * TclOOClassSetMixinsk, or just below if this function fails. */ + AddRef(mixins[i-1]->thisPtr); } @@ -1661,6 +1701,7 @@ TclOODefineMixinObjCmd( * ---------------------------------------------------------------------- * * TclOODefineRenameMethodObjCmd -- + * * Implementation of the "renamemethod" subcommand of the "oo::define" * and "oo::objdefine" commands. * @@ -1717,6 +1758,7 @@ TclOODefineRenameMethodObjCmd( * ---------------------------------------------------------------------- * * TclOODefineUnexportObjCmd -- + * * Implementation of the "unexport" subcommand of the "oo::define" and * "oo::objdefine" commands. * @@ -1811,6 +1853,7 @@ TclOODefineUnexportObjCmd( * ---------------------------------------------------------------------- * * Tcl_ClassSetConstructor, Tcl_ClassSetDestructor -- + * * How to install a constructor or destructor into a class; API to call * from C. * @@ -1865,6 +1908,7 @@ Tcl_ClassSetDestructor( * ---------------------------------------------------------------------- * * TclOODefineSlots -- + * * Create the "::oo::Slot" class and its standard instances. Class * definition is empty at the stage (added by scripting). * @@ -1908,6 +1952,7 @@ TclOODefineSlots( * ---------------------------------------------------------------------- * * ClassFilterGet, ClassFilterSet -- + * * Implementation of the "filter" slot accessors of the "oo::define" * command. * @@ -1987,6 +2032,7 @@ ClassFilterSet( * ---------------------------------------------------------------------- * * ClassMixinGet, ClassMixinSet -- + * * Implementation of the "mixin" slot accessors of the "oo::define" * command. * @@ -2077,9 +2123,12 @@ ClassMixinSet( Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL); goto freeAndError; } - /* Corresponding TclOODecrRefCount() is in TclOOClassSetMixins, or just - * below if this function fails + + /* + * Corresponding TclOODecrRefCount() is in TclOOClassSetMixins, or + * just below if this function fails. */ + AddRef(mixins[i]->thisPtr); } @@ -2099,6 +2148,7 @@ ClassMixinSet( * ---------------------------------------------------------------------- * * ClassSuperGet, ClassSuperSet -- + * * Implementation of the "superclass" slot accessors of the "oo::define" * command. * @@ -2199,7 +2249,11 @@ ClassSuperSet( superclasses[0] = oPtr->fPtr->objectCls; } superc = 1; - /* Corresponding TclOODecrRefCount is near the end of this function */ + + /* + * Corresponding TclOODecrRefCount is near the end of this function. + */ + AddRef(superclasses[0]->thisPtr); } else { for (i=0 ; ithisPtr); } } @@ -2252,7 +2310,11 @@ ClassSuperSet( oPtr->classPtr->superclasses.num = superc; FOREACH(superPtr, oPtr->classPtr->superclasses) { TclOOAddToSubclasses(oPtr->classPtr, superPtr); - /* To account for the AddRef() earlier in this function */ + + /* + * To account for the AddRef() earlier in this function. + */ + TclOODecrRefCount(superPtr->thisPtr); } BumpGlobalEpoch(interp, oPtr->classPtr); @@ -2264,6 +2326,7 @@ ClassSuperSet( * ---------------------------------------------------------------------- * * ClassVarsGet, ClassVarsSet -- + * * Implementation of the "variable" slot accessors of the "oo::define" * command. * @@ -2406,6 +2469,7 @@ ClassVarsSet( * ---------------------------------------------------------------------- * * ObjectFilterGet, ObjectFilterSet -- + * * Implementation of the "filter" slot accessors of the "oo::objdefine" * command. * @@ -2473,6 +2537,7 @@ ObjFilterSet( * ---------------------------------------------------------------------- * * ObjectMixinGet, ObjectMixinSet -- + * * Implementation of the "mixin" slot accessors of the "oo::objdefine" * command. * @@ -2550,9 +2615,12 @@ ObjMixinSet( TclStackFree(interp, mixins); return TCL_ERROR; } - /* Corresponding TclOODecrRefCount() is in TclOOObjectSetMixins() or + + /* + * Corresponding TclOODecrRefCount() is in TclOOObjectSetMixins() or * just above if this function fails. */ + AddRef(mixins[i]->thisPtr); } @@ -2565,6 +2633,7 @@ ObjMixinSet( * ---------------------------------------------------------------------- * * ObjectVarsGet, ObjectVarsSet -- + * * Implementation of the "variable" slot accessors of the "oo::objdefine" * command. * -- cgit v0.12 From 48456596fff560a8a2e3bb709c7683d07874d306 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 9 Jan 2018 11:15:14 +0000 Subject: (partial) fix for [https://core.tcl.tk/tk/info/00a27923ee26437611e1ed83f96e15b6caabcd8b|00a27923ee]: text/entry dysfunctional when pasting an emoji on MacOSX. Don't handle incoming valid 4-byte UTF-8 characters as invalid byte sequences (since they aren't), but as being the Unicode replacement character. --- generic/tclUtf.c | 24 ++++++++++++++---------- 1 file changed, 14 insertions(+), 10 deletions(-) diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 6255a4e..f7ceaab 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -68,11 +68,7 @@ static const unsigned char totalBytes[256] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3, -#if TCL_UTF_MAX > 3 4,4,4,4,4,4,4,4, -#else - 1,1,1,1,1,1,1,1, -#endif 1,1,1,1,1,1,1,1 }; @@ -334,13 +330,22 @@ Tcl_UtfToUniChar( * represents itself. */ } -#if TCL_UTF_MAX > 3 else if (byte < 0xF8) { if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80) && ((src[3] & 0xC0) == 0x80)) { /* * Four-byte-character lead byte followed by three trail bytes. */ -#if TCL_UTF_MAX == 4 +#if TCL_UTF_MAX == 3 + byte = (((byte & 0x07) << 18) | ((src[1] & 0x3F) << 12) + | ((src[2] & 0x3F) << 6) | (src[3] & 0x3F)) - 0x10000; + if (byte & 0x100000) { + /* out of range, < 0x10000 or > 0x10ffff */ + } else { + /* produce replacement character, and advance source pointer */ + *chPtr = (Tcl_UniChar) 0xFFFD; + return 4; + } +#elif TCL_UTF_MAX == 4 Tcl_UniChar surrogate; byte = (((byte & 0x07) << 18) | ((src[1] & 0x3F) << 12) @@ -371,7 +376,6 @@ Tcl_UtfToUniChar( * represents itself. */ } -#endif *chPtr = (Tcl_UniChar) byte; return 1; @@ -505,13 +509,13 @@ Tcl_NumUtfChars( } if (i < 0) i = INT_MAX; /* Bug [2738427] */ } else { - register const char *endPtr = src + length - TCL_UTF_MAX; + register const char *endPtr = src + length - 4; while (src < endPtr) { src += TclUtfToUniChar(src, &ch); i++; } - endPtr += TCL_UTF_MAX; + endPtr += 4; while ((src < endPtr) && Tcl_UtfCharComplete(src, endPtr - src)) { src += TclUtfToUniChar(src, &ch); i++; @@ -683,7 +687,7 @@ Tcl_UtfPrev( int i, byte; look = --src; - for (i = 0; i < TCL_UTF_MAX; i++) { + for (i = 0; i < 4; i++) { if (look < start) { if (src < start) { src = start; -- cgit v0.12 From 48d6a20861f95be856bef0e780c054757c9c3803 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 10 Jan 2018 14:02:03 +0000 Subject: Re-implement Tcl_WinTCharToUtf/Tcl_WinUtfToTChar in pure win32 api, even for TCL_UTF_MAX=3. We can do that now safely, because of the changed handling of valid 4-byte UTF-8 characters in the previous commit. --- generic/tclEvent.c | 1 - generic/tclIOUtil.c | 9 ------ generic/tclInt.h | 1 - generic/tclIntPlatDecls.h | 4 +++ generic/tclStubInit.c | 39 +++++++----------------- unix/tclUnixInit.c | 6 ---- win/tclWin32Dll.c | 76 ++--------------------------------------------- win/tclWinInit.c | 7 ----- 8 files changed, 17 insertions(+), 126 deletions(-) diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 49fd2ae..93cf983 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -1057,7 +1057,6 @@ TclInitSubsystems(void) * mutexes. */ TclInitIOSubsystem(); /* Inits a tsd key (noop). */ TclInitEncodingSubsystem(); /* Process wide encoding init. */ - TclpSetInterfaces(); TclInitNamespaceSubsystem();/* Register ns obj type (mutexed). */ subsystemsInitialized = 1; } diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 8fb3aa8..144bab0 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -830,15 +830,6 @@ TclResetFilesystem(void) if (++theFilesystemEpoch == 0) { ++theFilesystemEpoch; } - -#ifdef _WIN32 - /* - * Cleans up the win32 API filesystem proc lookup table. This must happen - * very late in finalization so that deleting of copied dlls can occur. - */ - - TclWinResetInterfaces(); -#endif } /* diff --git a/generic/tclInt.h b/generic/tclInt.h index 2ba0493..888adca 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3157,7 +3157,6 @@ MODULE_SCOPE Tcl_Obj * TclPathPart(Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_PathPart portion); MODULE_SCOPE char * TclpReadlink(const char *fileName, Tcl_DString *linkPtr); -MODULE_SCOPE void TclpSetInterfaces(void); MODULE_SCOPE void TclpSetVariables(Tcl_Interp *interp); MODULE_SCOPE void * TclThreadStorageKeyGet(Tcl_ThreadDataKey *keyPtr); MODULE_SCOPE void TclThreadStorageKeySet(Tcl_ThreadDataKey *keyPtr, diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index 1222cee..ada1d2b 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -549,6 +549,10 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; #define TclWinConvertWSAError TclWinConvertError #undef TclpInetNtoa #define TclpInetNtoa inet_ntoa +#undef TclWinResetInterfaces +#define TclWinResetInterfaces() /* nop */ +#undef TclWinSetInterfaces +#define TclWinSetInterfaces(dummy) /* nop */ #if defined(_WIN32) # undef TclWinNToHS diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 227bf02..e25b148 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -104,6 +104,13 @@ static const char *TclGetStartupScriptFileName(void) #if defined(_WIN32) || defined(__CYGWIN__) #undef TclWinNToHS #undef TclWinGetPlatformId +#undef TclWinResetInterfaces +#undef TclWinSetInterfaces +static void +doNothing(void) +{ + /* dummy implementation, no need to do anything */ +} #if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 #define TclWinNToHS winNToHS static unsigned short TclWinNToHS(unsigned short ns) { @@ -115,9 +122,13 @@ TclWinGetPlatformId(void) { return 2; /* VER_PLATFORM_WIN32_NT */; } +#define TclWinResetInterfaces doNothing +#define TclWinSetInterfaces (void (*) (int)) doNothing #else #define TclWinNToHS 0 #define TclWinGetPlatformId 0 +#define TclWinResetInterfaces 0 +#define TclWinSetInterfaces 0 #endif #endif # define TclBNInitBignumFromWideUInt TclInitBignumFromWideUInt @@ -133,14 +144,8 @@ TclWinGetPlatformId(void) # define TclpIsAtty 0 #elif defined(__CYGWIN__) # define TclpIsAtty TclPlatIsAtty -# define TclWinSetInterfaces (void (*) (int)) doNothing # define TclWinAddProcess (void (*) (void *, unsigned int)) doNothing # define TclWinFlushDirtyChannels doNothing -# define TclWinResetInterfaces doNothing - -#if TCL_UTF_MAX < 4 -static Tcl_Encoding winTCharEncoding; -#endif static int TclpIsAtty(int fd) @@ -201,19 +206,12 @@ TclpGetPid(Tcl_Pid pid) return (int) (size_t) pid; } -static void -doNothing(void) -{ - /* dummy implementation, no need to do anything */ -} - char * Tcl_WinUtfToTChar( const char *string, int len, Tcl_DString *dsPtr) { -#if TCL_UTF_MAX > 3 WCHAR *wp; int size = MultiByteToWideChar(CP_UTF8, 0, string, len, 0, 0); @@ -225,13 +223,6 @@ Tcl_WinUtfToTChar( Tcl_DStringSetLength(dsPtr, 2*size); wp[size] = 0; return (char *)wp; -#else - if (!winTCharEncoding) { - winTCharEncoding = Tcl_GetEncoding(0, "unicode"); - } - return Tcl_UtfToExternalDString(winTCharEncoding, - string, len, dsPtr); -#endif } char * @@ -240,7 +231,6 @@ Tcl_WinTCharToUtf( int len, Tcl_DString *dsPtr) { -#if TCL_UTF_MAX > 3 char *p; int size; @@ -256,13 +246,6 @@ Tcl_WinTCharToUtf( Tcl_DStringSetLength(dsPtr, size); p[size] = 0; return p; -#else - if (!winTCharEncoding) { - winTCharEncoding = Tcl_GetEncoding(0, "unicode"); - } - return Tcl_ExternalToUtfDString(winTCharEncoding, - string, len, dsPtr); -#endif } #if defined(TCL_WIDE_INT_IS_LONG) diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index cc66569..630460a 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -577,12 +577,6 @@ TclpSetInitialEncodings(void) Tcl_DStringFree(&encodingName); } -void -TclpSetInterfaces(void) -{ - /* do nothing */ -} - static const char * SearchKnownEncodings( const char *encoding) diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c index da1cdfe..599c126 100644 --- a/win/tclWin32Dll.c +++ b/win/tclWin32Dll.c @@ -32,10 +32,6 @@ static HINSTANCE hInstance; /* HINSTANCE of this DLL. */ #define cpuid __asm __emit 0fh __asm __emit 0a2h #endif -#if TCL_UTF_MAX < 4 -static Tcl_Encoding winTCharEncoding = NULL; -#endif - /* * The following declaration is for the VC++ DLL entry point. */ @@ -196,8 +192,6 @@ TclWinInit( if (os.dwPlatformId != VER_PLATFORM_WIN32_NT) { Tcl_Panic("Windows NT is the only supported platform"); } - - TclWinResetInterfaces(); } /* @@ -234,38 +228,10 @@ TclWinNoBackslash( /* *--------------------------------------------------------------------------- * - * TclpSetInterfaces -- - * - * A helper proc. - * - * Results: - * None. - * - * Side effects: - * None. - * - *--------------------------------------------------------------------------- - */ - -void -TclpSetInterfaces(void) -{ -#if TCL_UTF_MAX < 4 - TclWinResetInterfaces(); - winTCharEncoding = Tcl_GetEncoding(NULL, "unicode"); -#endif -} - -/* - *--------------------------------------------------------------------------- - * * TclWinEncodingsCleanup -- * - * Called during finalization to free up any encodings we use. - * - * We also clean up any memory allocated in our mount point map which is - * used to follow certain kinds of symlinks. That code should never be - * used once encodings are taken down. + * Called during finalization to clean up any memory allocated in our + * mount point map which is used to follow certain kinds of symlinks. * * Results: * None. @@ -281,8 +247,6 @@ TclWinEncodingsCleanup(void) { MountPointMap *dlIter, *dlIter2; - TclWinResetInterfaces(); - /* * Clean up the mount point map. */ @@ -299,32 +263,6 @@ TclWinEncodingsCleanup(void) } /* - *--------------------------------------------------------------------------- - * - * TclWinResetInterfaces -- - * - * Called during finalization to reset us to a safe state for reuse. - * - * Results: - * None. - * - * Side effects: - * None. - * - *--------------------------------------------------------------------------- - */ -void -TclWinResetInterfaces(void) -{ -#if TCL_UTF_MAX < 4 - if (winTCharEncoding != NULL) { - Tcl_FreeEncoding(winTCharEncoding); - winTCharEncoding = NULL; - } -#endif -} - -/* *-------------------------------------------------------------------- * * TclWinDriveLetterForVolMountPoint @@ -533,7 +471,6 @@ Tcl_WinUtfToTChar( Tcl_DString *dsPtr) /* Uninitialized or free DString in which the * converted string is stored. */ { -#if TCL_UTF_MAX > 3 TCHAR *wp; int size = MultiByteToWideChar(CP_UTF8, 0, string, len, 0, 0); @@ -545,10 +482,6 @@ Tcl_WinUtfToTChar( Tcl_DStringSetLength(dsPtr, 2*size); wp[size] = 0; return wp; -#else - return (TCHAR *) Tcl_UtfToExternalDString(winTCharEncoding, - string, len, dsPtr); -#endif } char * @@ -559,7 +492,6 @@ Tcl_WinTCharToUtf( Tcl_DString *dsPtr) /* Uninitialized or free DString in which the * converted string is stored. */ { -#if TCL_UTF_MAX > 3 char *p; int size; @@ -575,10 +507,6 @@ Tcl_WinTCharToUtf( Tcl_DStringSetLength(dsPtr, size); p[size] = 0; return p; -#else - return Tcl_ExternalToUtfDString(winTCharEncoding, - (const char *) string, len, dsPtr); -#endif } /* diff --git a/win/tclWinInit.c b/win/tclWinInit.c index dc8bba7..91f149b 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -487,18 +487,11 @@ TclpSetInitialEncodings(void) { Tcl_DString encodingName; - TclpSetInterfaces(); Tcl_SetSystemEncoding(NULL, Tcl_GetEncodingNameFromEnvironment(&encodingName)); Tcl_DStringFree(&encodingName); } -void TclWinSetInterfaces( - int dummy) /* Not used. */ -{ - TclpSetInterfaces(); -} - const char * Tcl_GetEncodingNameFromEnvironment( Tcl_DString *bufPtr) -- cgit v0.12 From 45e646472daf2fe6beb41555fe088b929cd2ce6c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 11 Jan 2018 15:44:05 +0000 Subject: Fix behavior of Tcl_GetRange() and "string range" regarding surrogates, when Tcl is compiled with -DTCL_UTF_MAX=4. Partial fix for bug [11ae2be95dac9417]. Also, fix typo. --- generic/tclStringObj.c | 13 ++++++++++++- tests/string.test | 4 ++++ 2 files changed, 16 insertions(+), 1 deletion(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 0f238cf..1b35c56 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -533,7 +533,7 @@ Tcl_GetUniChar( * * Get the Unicode form of the String object. If the object is not * already a String object, it will be converted to one. If the String - * object does not have a Unicode rep, then one is create from the UTF + * object does not have a Unicode rep, then one is created from the UTF * string format. * * Results: @@ -667,6 +667,17 @@ Tcl_GetRange( stringPtr = GET_STRING(objPtr); } +#if TCL_UTF_MAX == 4 + /* See: bug [11ae2be95dac9417] */ + if ((first>0) && ((stringPtr->unicode[first]&0xFC00) == 0xDC00) + && ((stringPtr->unicode[first-1]&0xFC00) == 0xD800)) { + ++first; + } + if ((last+1numChars) && ((stringPtr->unicode[last+1]&0xFC00) == 0xDC00) + && ((stringPtr->unicode[last]&0xFC00) == 0xD800)) { + ++last; + } +#endif return Tcl_NewUnicodeObj(stringPtr->unicode + first, last-first+1); } diff --git a/tests/string.test b/tests/string.test index bbba5eb..53f1cfb 100644 --- a/tests/string.test +++ b/tests/string.test @@ -24,6 +24,7 @@ catch [list package require -exact Tcltest [info patchlevel]] testConstraint testobj [expr {[info commands testobj] != {}}] testConstraint testindexobj [expr {[info commands testindexobj] != {}}] +testConstraint fullutf [expr {[format %c 0x010000] != "\ufffd"}] # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] @@ -1276,6 +1277,9 @@ test string-12.22 {string range, shimmering binary/index} { binary scan $s a* x string range $s $s end } 000000001 +test string-12.23 {string range, surrogates, bug [11ae2be95dac9417]} fullutf { + list [string range a\U100000b 1 1] [string range a\U100000b 2 2] [string range a\U100000b 3 3] +} [list \U100000 {} b] test string-13.1 {string repeat} { list [catch {string repeat} msg] $msg -- cgit v0.12