summaryrefslogtreecommitdiffstats
path: root/generic/tclOO.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclOO.c')
-rw-r--r--generic/tclOO.c652
1 files changed, 293 insertions, 359 deletions
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 216219d..e9b673b 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -4,6 +4,7 @@
* This file contains the object-system core (NB: not Tcl_Obj, but ::oo)
*
* Copyright (c) 2005-2012 by Donal K. Fellows
+ * Copyright (c) 2017 by Nathan Coulter
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -58,7 +59,7 @@ static const struct {
static Class * AllocClass(Tcl_Interp *interp, Object *useThisObj);
static Object * AllocObject(Tcl_Interp *interp, const char *nameStr,
- const char *nsNameStr);
+ Namespace *nsPtr, const char *nsNameStr);
static void ClearMixins(Class *clsPtr);
static void ClearSuperclasses(Class *clsPtr);
static int CloneClassMethod(Tcl_Interp *interp, Class *clsPtr,
@@ -82,7 +83,6 @@ static void ObjectRenamedTrace(ClientData clientData,
const char *newName, int flags);
static void ReleaseClassContents(Tcl_Interp *interp,Object *oPtr);
static inline void SquelchCachedName(Object *oPtr);
-static void SquelchedNsFirst(ClientData clientData);
static int PublicObjectCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
@@ -380,9 +380,9 @@ InitFoundation(
*/
fPtr->objectCls = AllocClass(interp,
- AllocObject(interp, "::oo::object", NULL));
+ AllocObject(interp, "object", (Namespace *)fPtr->ooNs, NULL));
fPtr->classCls = AllocClass(interp,
- AllocObject(interp, "::oo::class", NULL));
+ AllocObject(interp, "class", (Namespace *)fPtr->ooNs, NULL));
fPtr->objectCls->thisPtr->selfCls = fPtr->classCls;
fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT;
fPtr->objectCls->flags |= ROOT_OBJECT;
@@ -552,6 +552,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 */
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
@@ -581,8 +583,7 @@ AllocObject(
*/
if (nsNameStr != NULL) {
- oPtr->namespacePtr = Tcl_CreateNamespace(interp, nsNameStr, oPtr,
- ObjectNamespaceDeleted);
+ oPtr->namespacePtr = Tcl_CreateNamespace(interp, nsNameStr, oPtr, NULL);
if (oPtr->namespacePtr != NULL) {
creationEpoch = ++fPtr->tsdPtr->nsCount;
goto configNamespace;
@@ -594,8 +595,7 @@ AllocObject(
char objName[10 + TCL_INTEGER_SPACE];
sprintf(objName, "::oo::Obj%" TCL_LL_MODIFIER "d", (Tcl_WideInt)++fPtr->tsdPtr->nsCount);
- oPtr->namespacePtr = Tcl_CreateNamespace(interp, objName, oPtr,
- ObjectNamespaceDeleted);
+ oPtr->namespacePtr = Tcl_CreateNamespace(interp, objName, oPtr, NULL);
if (oPtr->namespacePtr != NULL) {
creationEpoch = fPtr->tsdPtr->nsCount;
break;
@@ -635,7 +635,7 @@ AllocObject(
* access variables in it. [Bug 2950259]
*/
- ((Namespace *) oPtr->namespacePtr)->earlyDeleteProc = SquelchedNsFirst;
+ ((Namespace *) oPtr->namespacePtr)->earlyDeleteProc = ObjectNamespaceDeleted;
/*
* Fill in the rest of the non-zero/NULL parts of the structure.
@@ -654,23 +654,11 @@ AllocObject(
*/
if (!nameStr) {
- oPtr->command = Tcl_CreateObjCommand(interp,
- oPtr->namespacePtr->fullName, PublicObjectCmd, oPtr, NULL);
- } else if (nameStr[0] == ':' && nameStr[1] == ':') {
- oPtr->command = Tcl_CreateObjCommand(interp, nameStr,
- PublicObjectCmd, oPtr, NULL);
- } else {
- Tcl_DString buffer;
-
- Tcl_DStringInit(&buffer);
- Tcl_DStringAppend(&buffer,
- Tcl_GetCurrentNamespace(interp)->fullName, -1);
- TclDStringAppendLiteral(&buffer, "::");
- Tcl_DStringAppend(&buffer, nameStr, -1);
- oPtr->command = Tcl_CreateObjCommand(interp,
- Tcl_DStringValue(&buffer), PublicObjectCmd, oPtr, NULL);
- Tcl_DStringFree(&buffer);
+ nameStr = oPtr->namespacePtr->name;
+ nsPtr = (Namespace *)oPtr->namespacePtr;
}
+ oPtr->command = TclCreateObjCommandInNs(interp, nameStr,
+ (Tcl_Namespace *)nsPtr, PublicObjectCmd, oPtr, NULL);
/*
* Add the NRE command and trace directly. While this breaks a number of
@@ -756,30 +744,6 @@ MyDeleted(
/*
* ----------------------------------------------------------------------
*
- * SquelchedNsFirst --
- *
- * This callback is triggered when the object's namespace is deleted by
- * any mechanism. It deletes the object's public command if it has not
- * already been deleted, so ensuring that destructors get run at an
- * appropriate time. [Bug 2950259]
- *
- * ----------------------------------------------------------------------
- */
-
-static void
-SquelchedNsFirst(
- ClientData clientData)
-{
- Object *oPtr = clientData;
-
- if (oPtr->command) {
- Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command);
- }
-}
-
-/*
- * ----------------------------------------------------------------------
- *
* ObjectRenamedTrace --
*
* This callback is triggered when the object is deleted by any
@@ -799,8 +763,6 @@ ObjectRenamedTrace(
int flags) /* Why was the object deleted? */
{
Object *oPtr = clientData;
- Foundation *fPtr = oPtr->fPtr;
-
/*
* If this is a rename and not a delete of the object, we just flush the
* cache of the object name.
@@ -812,87 +774,35 @@ ObjectRenamedTrace(
}
/*
- * Oh dear, the object really is being deleted. Handle this by running the
- * destructors and deleting the object's namespace, which in turn causes
- * the real object structures to be deleted.
- *
- * Note that it is possible for the namespace to be deleted before the
- * command. Because of that case, we must take care here to mark the
- * command as being deleted so that if we return here we don't run into
- * reentrancy problems.
- *
- * We also do not run destructors on the core class objects when the
- * interpreter is being deleted; their incestuous nature causes problems
- * in that case when the destructor is partially deleted before the uses
- * of it have gone. [Bug 2949397]
- */
-
- AddRef(oPtr);
- AddRef(fPtr->classCls);
- AddRef(fPtr->objectCls);
- AddRef(fPtr->classCls->thisPtr);
- AddRef(fPtr->objectCls->thisPtr);
- oPtr->command = NULL;
-
- if (!(oPtr->flags & DESTRUCTOR_CALLED) && !Tcl_InterpDeleted(interp)) {
- 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;
- state = Tcl_SaveInterpState(interp, TCL_OK);
- result = Tcl_NRCallObjProc(interp, TclOOInvokeContext,
- contextPtr, 0, NULL);
- if (result != TCL_OK) {
- Tcl_BackgroundException(interp, result);
- }
- Tcl_RestoreInterpState(interp, state);
- TclOODeleteContext(contextPtr);
- }
- }
-
- /*
- * OK, the destructor's been run. Time to splat the class data (if any)
- * and nuke the namespace (which triggers the final crushing of the object
- * structure itself).
- *
- * 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 (!Tcl_InterpDeleted(interp) && IsRootObject(oPtr)
- && !Deleted(fPtr->classCls->thisPtr)) {
- Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command);
- }
-
- if (oPtr->classPtr != NULL) {
- AddRef(oPtr->classPtr);
- ReleaseClassContents(interp, oPtr);
- }
-
- /*
* The namespace is only deleted if it hasn't already been deleted. [Bug
- * 2950259]
+ * 2950259]. If the namespace has already been deleted, then
+ * ObjectNamespaceDeleted() has already cleaned up this command.
*/
- if (oPtr->namespacePtr && ((Namespace *) oPtr->namespacePtr)->earlyDeleteProc != NULL) {
- Tcl_DeleteNamespace(oPtr->namespacePtr);
- }
- if (oPtr->classPtr) {
- DelRef(oPtr->classPtr);
+ 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);
+ }
}
- DelRef(fPtr->classCls->thisPtr);
- DelRef(fPtr->objectCls->thisPtr);
- DelRef(fPtr->classCls);
- DelRef(fPtr->objectCls);
- DelRef(oPtr);
+ return;
}
/*
@@ -964,7 +874,9 @@ ReleaseClassContents(
int i;
Class *clsPtr = oPtr->classPtr, *mixinSubclassPtr, *subclassPtr;
Object *instancePtr;
+ Method *mPtr;
Foundation *fPtr = oPtr->fPtr;
+ Tcl_Obj *variableObj;
/*
* Sanity check!
@@ -1002,28 +914,30 @@ ReleaseClassContents(
}
if (!IsRootClass(oPtr)) {
FOREACH(instancePtr, clsPtr->instances) {
- int j;
- if (instancePtr->selfCls == clsPtr) {
- instancePtr->flags |= CLASS_GONE;
- }
- for(j=0 ; j<instancePtr->mixins.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;
+ if (instancePtr != oPtr) {
+ int j;
+ if (instancePtr->selfCls == clsPtr) {
+ instancePtr->flags |= CLASS_GONE;
+ }
+ for(j=0 ; j<instancePtr->mixins.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;
}
- instancePtr->mixins.num -= 1;
}
- }
- if (instancePtr != NULL && !IsRoot(instancePtr)) {
- AddRef(instancePtr);
+ if (instancePtr != NULL && !IsRoot(instancePtr)) {
+ AddRef(instancePtr);
+ }
}
}
}
@@ -1033,13 +947,15 @@ ReleaseClassContents(
*/
FOREACH(mixinSubclassPtr, clsPtr->mixinSubs) {
- if (!Deleted(mixinSubclassPtr->thisPtr)) {
- Tcl_DeleteCommandFromToken(interp,
- mixinSubclassPtr->thisPtr->command);
+ if (mixinSubclassPtr != clsPtr) {
+ if (!Deleted(mixinSubclassPtr->thisPtr)) {
+ Tcl_DeleteCommandFromToken(interp,
+ mixinSubclassPtr->thisPtr->command);
+ }
+ ClearMixins(mixinSubclassPtr);
+ DelRef(mixinSubclassPtr->thisPtr);
+ DelRef(mixinSubclassPtr);
}
- ClearMixins(mixinSubclassPtr);
- DelRef(mixinSubclassPtr->thisPtr);
- DelRef(mixinSubclassPtr);
}
if (clsPtr->mixinSubs.list != NULL) {
ckfree(clsPtr->mixinSubs.list);
@@ -1074,19 +990,21 @@ ReleaseClassContents(
if (!IsRootClass(oPtr)) {
FOREACH(instancePtr, clsPtr->instances) {
- 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;
+ 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);
}
- DelRef(instancePtr);
}
}
if (clsPtr->instances.list != NULL) {
@@ -1155,6 +1073,30 @@ ReleaseClassContents(
ckfree(clsPtr->metadataPtr);
clsPtr->metadataPtr = NULL;
}
+
+ ClearMixins(clsPtr);
+ ClearSuperclasses(clsPtr);
+
+ FOREACH_HASH_VALUE(mPtr, &clsPtr->classMethods) {
+ TclOODelMethodRef(mPtr);
+ }
+ Tcl_DeleteHashTable(&clsPtr->classMethods);
+ TclOODelMethodRef(clsPtr->constructorPtr);
+ TclOODelMethodRef(clsPtr->destructorPtr);
+
+ FOREACH(variableObj, clsPtr->variables) {
+ TclDecrRefCount(variableObj);
+ }
+ if (i) {
+ 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);
+
}
/*
@@ -1176,31 +1118,71 @@ ObjectNamespaceDeleted(
* being deleted. */
{
Object *oPtr = clientData;
+ Foundation *fPtr = oPtr->fPtr;
FOREACH_HASH_DECLS;
- Class *clsPtr = oPtr->classPtr, *mixinPtr;
+ Class *mixinPtr;
Method *mPtr;
Tcl_Obj *filterObj, *variableObj;
- int deleteAlreadyInProgress = 0, i;
+ Tcl_Interp *interp = oPtr->fPtr->interp;
+ int finished = 0, i;
+
+
+ AddRef(fPtr->classCls);
+ AddRef(fPtr->objectCls);
+ AddRef(fPtr->classCls->thisPtr);
+ AddRef(fPtr->objectCls->thisPtr);
/*
- * Instruct everyone to no longer use any allocated fields of the object.
- * Also delete the commands that refer to the object at this point (if
- * they still exist) because otherwise their references to the object
- * point into freed memory, allowing crashes.
+ * We do not run destructors on the core class objects when the
+ * interpreter is being deleted; their incestuous nature causes problems
+ * in that case when the destructor is partially deleted before the uses
+ * of it have gone. [Bug 2949397]
*/
- if (oPtr->command) {
- if ((((Command *)oPtr->command)->flags && CMD_IS_DELETED)) {
- /*
- * Namespace deletion must have been triggered by a trace on command
- * deletion , meaning that ObjectRenamedTrace() is eventually going
- * to be called .
- */
- deleteAlreadyInProgress = 1;
+ if (!(oPtr->flags & DESTRUCTOR_CALLED) && !Tcl_InterpDeleted(interp)) {
+ 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;
+ state = Tcl_SaveInterpState(interp, TCL_OK);
+ result = Tcl_NRCallObjProc(interp, TclOOInvokeContext,
+ contextPtr, 0, NULL);
+ if (result != TCL_OK) {
+ Tcl_BackgroundException(interp, result);
+ }
+ Tcl_RestoreInterpState(interp, state);
+ TclOODeleteContext(contextPtr);
}
+ }
+
+ /*
+ * Instruct everyone to no longer use any allocated fields of the object.
+ * Also delete the command that refers to the object at this point (if
+ * it still exists) because otherwise its pointer to the object
+ * points into freed memory.
+ */
+ 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,
+ */
+ } else {
+ /*
+ * The namespace must have been deleted directly. Delete the command
+ * as well.
+ */
Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command);
+ finished = 1;
}
+ oPtr->command = NULL;
+
if (oPtr->myCommand) {
Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myCommand);
}
@@ -1215,7 +1197,7 @@ ObjectNamespaceDeleted(
}
FOREACH(mixinPtr, oPtr->mixins) {
- if (mixinPtr) {
+ if (mixinPtr && mixinPtr != oPtr->classPtr) {
TclOORemoveFromInstances(oPtr, mixinPtr);
}
}
@@ -1264,77 +1246,51 @@ ObjectNamespaceDeleted(
}
/*
- * If this was a class, there's additional deletion work to do.
+ * 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.
*/
- if (clsPtr != NULL) {
- Tcl_ObjectMetadataType *metadataTypePtr;
- ClientData value;
-
- if (clsPtr->metadataPtr != NULL) {
- FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) {
- metadataTypePtr->deleteProc(value);
- }
- Tcl_DeleteHashTable(clsPtr->metadataPtr);
- ckfree(clsPtr->metadataPtr);
- clsPtr->metadataPtr = NULL;
- }
- FOREACH(filterObj, clsPtr->filters) {
- TclDecrRefCount(filterObj);
- }
- if (i) {
- ckfree(clsPtr->filters.list);
- clsPtr->filters.num = 0;
- }
-
- ClearMixins(clsPtr);
-
- ClearSuperclasses(clsPtr);
-
- if (clsPtr->subclasses.list) {
- ckfree(clsPtr->subclasses.list);
- clsPtr->subclasses.list = NULL;
- clsPtr->subclasses.num = 0;
- }
- if (clsPtr->instances.list) {
- ckfree(clsPtr->instances.list);
- clsPtr->instances.list = NULL;
- clsPtr->instances.num = 0;
- }
- if (clsPtr->mixinSubs.list) {
- ckfree(clsPtr->mixinSubs.list);
- clsPtr->mixinSubs.list = NULL;
- clsPtr->mixinSubs.num = 0;
- }
-
- FOREACH_HASH_VALUE(mPtr, &clsPtr->classMethods) {
- TclOODelMethodRef(mPtr);
- }
- Tcl_DeleteHashTable(&clsPtr->classMethods);
- TclOODelMethodRef(clsPtr->constructorPtr);
- TclOODelMethodRef(clsPtr->destructorPtr);
-
- FOREACH(variableObj, clsPtr->variables) {
- TclDecrRefCount(variableObj);
- }
- if (i) {
- ckfree(clsPtr->variables.list);
- }
+ /*
+ * 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 (!Tcl_InterpDeleted(interp) && IsRootObject(oPtr)
+ && !Deleted(fPtr->classCls->thisPtr)) {
+ Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command);
+ }
- DelRef(clsPtr);
+ if (oPtr->classPtr != NULL) {
+ ReleaseClassContents(interp, oPtr);
}
+
/*
* Delete the object structure itself.
*/
- if (deleteAlreadyInProgress) {
- oPtr->classPtr = NULL;
- oPtr->namespacePtr = NULL;
- } else {
+ 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).
+ */
}
+ return;
}
@@ -1428,7 +1384,7 @@ TclOOAddToInstances(
void
TclOORemoveFromSubclasses(
Class *subPtr, /* The subclass to remove. */
- Class *superPtr) /* The superclass to (possibly) remove the
+ Class *superPtr) /* The superclass to possibly remove the
* subclass reference from. */
{
int i;
@@ -1499,7 +1455,7 @@ TclOOAddToSubclasses(
void
TclOORemoveFromMixinSubs(
Class *subPtr, /* The subclass to remove. */
- Class *superPtr) /* The superclass to (possibly) remove the
+ Class *superPtr) /* The superclass to possibly remove the
* subclass reference from. */
{
int i;
@@ -1573,7 +1529,7 @@ AllocClass(
* 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. */
+ * with automatic name is to be used. */
{
Foundation *fPtr = GetFoundation(interp);
Class *clsPtr = ckalloc(sizeof(Class));
@@ -1584,7 +1540,7 @@ AllocClass(
memset(clsPtr, 0, sizeof(Class));
if (useThisObj == NULL) {
- clsPtr->thisPtr = AllocObject(interp, NULL, NULL);
+ clsPtr->thisPtr = AllocObject(interp, NULL, NULL, NULL);
} else {
clsPtr->thisPtr = useThisObj;
}
@@ -1645,7 +1601,6 @@ AllocClass(
*
* ----------------------------------------------------------------------
*/
-
Tcl_Object
Tcl_NewObjectInstance(
Tcl_Interp *interp, /* Interpreter context. */
@@ -1662,54 +1617,15 @@ Tcl_NewObjectInstance(
* constructor. */
{
register Class *classPtr = (Class *) cls;
- Foundation *fPtr = GetFoundation(interp);
Object *oPtr;
+ ClientData clientData[4];
- /*
- * Check if we're going to create an object over an existing command;
- * that's not allowed.
- */
-
- if (nameStr && Tcl_FindCommand(interp, nameStr, NULL,
- TCL_NAMESPACE_ONLY)) {
- 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;
- }
-
- /*
- * Create the object.
- */
-
- oPtr = AllocObject(interp, nameStr, 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.
- */
-
- if (TclOOIsReachable(fPtr->classCls, classPtr)) {
- /*
- * Is a class, so attach a class structure. Note that the AllocClass
- * function splices the structure into the object, so we don't have
- * to. Once that's done, we need to repatch the object to have the
- * right class since AllocClass interferes with that.
- */
-
- AllocClass(interp, oPtr);
- oPtr->selfCls = classPtr;
- TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls);
- } else {
- oPtr->classPtr = NULL;
- }
+ oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr);
+ if (oPtr == NULL) {return NULL;}
/*
- * Run constructors, except when objc < 0 (a special flag case used for
- * object cloning only).
+ * Run constructors, except when objc < 0, which is a special flag case
+ * used for object cloning only.
*/
if (objc >= 0) {
@@ -1736,36 +1652,16 @@ Tcl_NewObjectInstance(
TclResetRewriteEnsemble(interp, 1);
}
- /*
- * It's an error if the object was whacked in the constructor.
- * Force this if it isn't already an error (don't want to lose
- * errors by accident...) [Bug 2903011]
- */
+ clientData[0] = contextPtr;
+ clientData[1] = oPtr;
+ clientData[2] = state;
+ clientData[3] = &oPtr;
- if (result != TCL_ERROR && Deleted(oPtr)) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "object deleted in constructor", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL);
- result = TCL_ERROR;
- }
- TclOODeleteContext(contextPtr);
+ AddRef(oPtr);
+ result = FinalizeAlloc(clientData, interp, result);
if (result != TCL_OK) {
- Tcl_DiscardInterpState(state);
-
- /*
- * Take care to not delete a deleted object; that would be
- * bad. [Bug 2903011] Also take care to make sure that we have
- * the name of the command before we delete it. [Bug
- * 9dd1bd7a74]
- */
-
- if (!Deleted(oPtr)) {
- (void) TclOOObjectName(interp, oPtr);
- Tcl_DeleteCommandFromToken(interp, oPtr->command);
- }
return NULL;
}
- Tcl_RestoreInterpState(interp, state);
}
}
@@ -1790,50 +1686,12 @@ TclNRNewObjectInstance(
* successful allocation. */
{
register Class *classPtr = (Class *) cls;
- Foundation *fPtr = GetFoundation(interp);
CallContext *contextPtr;
Tcl_InterpState state;
Object *oPtr;
- /*
- * Check if we're going to create an object over an existing command;
- * that's not allowed.
- */
-
- if (nameStr && Tcl_FindCommand(interp, nameStr, NULL,
- TCL_NAMESPACE_ONLY)) {
- 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 TCL_ERROR;
- }
-
- /*
- * Create the object.
- */
-
- oPtr = AllocObject(interp, nameStr, 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.
- */
-
- if (TclOOIsReachable(fPtr->classCls, classPtr)) {
- /*
- * Is a class, so attach a class structure. Note that the AllocClass
- * function splices the structure into the object, so we don't have
- * to. Once that's done, we need to repatch the object to have the
- * right class since AllocClass interferes with that.
- */
-
- AllocClass(interp, oPtr);
- oPtr->selfCls = classPtr;
- TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls);
- }
+ oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr);
+ if (oPtr == NULL) {return TCL_ERROR;}
/*
* Run constructors, except when objc < 0 (a special flag case used for
@@ -1855,7 +1713,7 @@ TclNRNewObjectInstance(
contextPtr->skip = skip;
/*
- * Adjust the ensmble tracking record if necessary. [Bug 3514761]
+ * Adjust the ensemble tracking record if necessary. [Bug 3514761]
*/
if (TclInitRewriteEnsemble(interp, skip, skip, objv)) {
@@ -1873,6 +1731,83 @@ TclNRNewObjectInstance(
return TclOOInvokeContext(contextPtr, interp, objc, objv);
}
+
+Object *
+TclNewObjectInstanceCommon(
+ Tcl_Interp *interp,
+ Class *classPtr,
+ const char *nameStr,
+ const char *nsNameStr)
+{
+ Tcl_HashEntry *hPtr;
+ Foundation *fPtr = GetFoundation(interp);
+ Object *oPtr;
+ const char *simpleName = NULL;
+ Namespace *nsPtr = NULL, *dummy,
+ *inNsPtr = (Namespace *)TclGetCurrentNamespace(interp);
+ int isNew;
+
+ if (nameStr) {
+ 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 {
+ 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;
+ }
+ }
+
+ /*
+ * 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.
+ */
+
+ if (TclOOIsReachable(fPtr->classCls, classPtr)) {
+ /*
+ * Is a class, so attach a class structure. Note that the AllocClass
+ * function splices the structure into the object, so we don't have
+ * to. Once that's done, we need to repatch the object to have the
+ * right class since AllocClass interferes with that.
+ */
+
+ AllocClass(interp, oPtr);
+ oPtr->selfCls = classPtr;
+ TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls);
+ } else {
+ oPtr->classPtr = NULL;
+ }
+ return oPtr;
+}
+
+
+
static int
FinalizeAlloc(
ClientData data[],
@@ -1885,9 +1820,8 @@ FinalizeAlloc(
Tcl_Object *objectPtr = data[3];
/*
- * It's an error if the object was whacked in the constructor. Force this
- * if it isn't already an error (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)) {
generated by cgit v0.12 at 2025-12-04 19:14:45 (GMT)