summaryrefslogtreecommitdiffstats
path: root/generic/tclOO.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclOO.c')
-rw-r--r--generic/tclOO.c525
1 files changed, 361 insertions, 164 deletions
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 8ac2039..9dd8162 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -28,27 +28,20 @@ static const struct {
{"deletemethod", TclOODefineDeleteMethodObjCmd, 0},
{"destructor", TclOODefineDestructorObjCmd, 0},
{"export", TclOODefineExportObjCmd, 0},
- {"filter", TclOODefineFilterObjCmd, 0},
{"forward", TclOODefineForwardObjCmd, 0},
{"method", TclOODefineMethodObjCmd, 0},
- {"mixin", TclOODefineMixinObjCmd, 0},
{"renamemethod", TclOODefineRenameMethodObjCmd, 0},
{"self", TclOODefineSelfObjCmd, 0},
- {"superclass", TclOODefineSuperclassObjCmd, 0},
{"unexport", TclOODefineUnexportObjCmd, 0},
- {"variable", TclOODefineVariablesObjCmd, 0},
{NULL, NULL, 0}
}, objdefCmds[] = {
{"class", TclOODefineClassObjCmd, 1},
{"deletemethod", TclOODefineDeleteMethodObjCmd, 1},
{"export", TclOODefineExportObjCmd, 1},
- {"filter", TclOODefineFilterObjCmd, 1},
{"forward", TclOODefineForwardObjCmd, 1},
{"method", TclOODefineMethodObjCmd, 1},
- {"mixin", TclOODefineMixinObjCmd, 1},
{"renamemethod", TclOODefineRenameMethodObjCmd, 1},
{"unexport", TclOODefineUnexportObjCmd, 1},
- {"variable", TclOODefineVariablesObjCmd, 1},
{NULL, NULL, 0}
};
@@ -79,7 +72,7 @@ static int FinalizeNext(ClientData data[],
Tcl_Interp *interp, int result);
static int FinalizeObjectCall(ClientData data[],
Tcl_Interp *interp, int result);
-static void InitFoundation(Tcl_Interp *interp);
+static int InitFoundation(Tcl_Interp *interp);
static void KillFoundation(ClientData clientData,
Tcl_Interp *interp);
static void MyDeleted(ClientData clientData);
@@ -129,12 +122,94 @@ static const DeclaredClassMethod objMethods[] = {
{NULL, 0, {0, NULL, NULL, NULL, NULL}}
};
-static char initScript[] =
- "package ifneeded TclOO " TCLOO_PATCHLEVEL " {# Already present, OK?};"
- "namespace eval ::oo { variable version " TCLOO_VERSION " };"
- "namespace eval ::oo { variable patchlevel " TCLOO_PATCHLEVEL " };";
-/* "tcl_findLibrary tcloo $oo::version $oo::version" */
-/* " tcloo.tcl OO_LIBRARY oo::library;"; */
+/*
+ * Scripted parts of TclOO. First, the master script (cannot be outside this
+ * file).
+ */
+
+static const char *initScript =
+"package ifneeded TclOO " TCLOO_PATCHLEVEL " {# Already present, OK?};"
+"namespace eval ::oo { variable version " TCLOO_VERSION " };"
+"namespace eval ::oo { variable patchlevel " TCLOO_PATCHLEVEL " };";
+/* "tcl_findLibrary tcloo $oo::version $oo::version" */
+/* " tcloo.tcl OO_LIBRARY oo::library;"; */
+
+/*
+ * The body of the constructor for oo::class.
+ */
+
+static const char *classConstructorBody =
+"set script [list ::oo::define [self] $definitionScript];"
+"lassign [::oo::UpCatch $script] msg opts;"
+"if {[dict get $opts -code] == 1} {"
+" dict set opts -errorline 0xDeadBeef"
+"};"
+"return -options $opts $msg;";
+
+/*
+ * The scripted part of the definitions of slots.
+ */
+
+static const char *slotScript =
+"::oo::define ::oo::Slot {\n"
+" method Get {} {error unimplemented}\n"
+" method Set list {error unimplemented}\n"
+" method -set args {\n"
+" uplevel 1 [list [namespace which my] Set $args]\n"
+" }\n"
+" method -append args {\n"
+" uplevel 1 [list [namespace which my] Set [list"
+" {*}[uplevel 1 [list [namespace which my] Get]] {*}$args]]\n"
+" }\n"
+" method -clear {} {uplevel 1 [list [namespace which my] Set {}]}\n"
+" forward --default-operation my -append\n"
+" method unknown {args} {\n"
+" set def --default-operation\n"
+" if {[llength $args] == 0} {\n"
+" return [uplevel 1 [list [namespace which my] $def]]\n"
+" } elseif {![string match -* [lindex $args 0]]} {\n"
+" return [uplevel 1 [list [namespace which my] $def {*}$args]]\n"
+" }\n"
+" next {*}$args\n"
+" }\n"
+" export -set -append -clear\n"
+" unexport unknown destroy\n"
+"}\n"
+"::oo::objdefine ::oo::define::superclass forward --default-operation my -set\n"
+"::oo::objdefine ::oo::define::mixin forward --default-operation my -set\n"
+"::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set\n";
+
+/*
+ * The body of the <cloned> method of oo::object.
+ */
+
+static const char *clonedBody =
+"foreach p [info procs [info object namespace $originObject]::*] {"
+" set args [info args $p];"
+" set idx -1;"
+" foreach a $args {"
+" lset args [incr idx] "
+" [if {[info default $p $a d]} {list $a $d} {list $a}]"
+" };"
+" set b [info body $p];"
+" set p [namespace tail $p];"
+" proc $p $args $b;"
+"};"
+"foreach v [info vars [info object namespace $originObject]::*] {"
+" upvar 0 $v vOrigin;"
+" namespace upvar [namespace current] [namespace tail $v] vNew;"
+" if {[info exists vOrigin]} {"
+" if {[array exists vOrigin]} {"
+" array set vNew [array get vOrigin];"
+" } else {"
+" set vNew $vOrigin;"
+" }"
+" }"
+"}";
+
+/*
+ * The actual definition of the variable holding the TclOO stub table.
+ */
MODULE_SCOPE const TclOOStubs tclOOStubs;
@@ -144,6 +219,20 @@ MODULE_SCOPE const TclOOStubs tclOOStubs;
#define GetFoundation(interp) \
((Foundation *)((Interp *)(interp))->objectFoundation)
+
+/*
+ * Macros to make inspecting into the guts of an object cleaner.
+ *
+ * The ocPtr parameter (only in these macros) is assumed to work fine with
+ * either an oPtr or a classPtr. Note that the roots oo::object and oo::class
+ * have _both_ their object and class flags tagged with ROOT_OBJECT and
+ * ROOT_CLASS respectively.
+ */
+
+#define Deleted(oPtr) (((Object *)(oPtr))->command == NULL)
+#define IsRootObject(ocPtr) ((ocPtr)->flags & ROOT_OBJECT)
+#define IsRootClass(ocPtr) ((ocPtr)->flags & ROOT_CLASS)
+#define IsRoot(ocPtr) ((ocPtr)->flags & (ROOT_OBJECT|ROOT_CLASS))
/*
* ----------------------------------------------------------------------
@@ -170,7 +259,9 @@ TclOOInit(
* Build the core of the OO system.
*/
- InitFoundation(interp);
+ if (InitFoundation(interp) != TCL_OK) {
+ return TCL_ERROR;
+ }
/*
* Run our initialization script and, if that works, declare the package
@@ -214,7 +305,7 @@ TclOOGetFoundation(
* ----------------------------------------------------------------------
*/
-static void
+static int
InitFoundation(
Tcl_Interp *interp)
{
@@ -245,17 +336,19 @@ InitFoundation(
DeletedHelpersNamespace);
fPtr->epoch = 0;
fPtr->tsdPtr = tsdPtr;
- fPtr->unknownMethodNameObj = Tcl_NewStringObj("unknown", -1);
- fPtr->constructorName = Tcl_NewStringObj("<constructor>", -1);
- fPtr->destructorName = Tcl_NewStringObj("<destructor>", -1);
+ TclNewLiteralStringObj(fPtr->unknownMethodNameObj, "unknown");
+ TclNewLiteralStringObj(fPtr->constructorName, "<constructor>");
+ TclNewLiteralStringObj(fPtr->destructorName, "<destructor>");
+ TclNewLiteralStringObj(fPtr->clonedName, "<cloned>");
Tcl_IncrRefCount(fPtr->unknownMethodNameObj);
Tcl_IncrRefCount(fPtr->constructorName);
Tcl_IncrRefCount(fPtr->destructorName);
+ Tcl_IncrRefCount(fPtr->clonedName);
Tcl_NRCreateCommand(interp, "::oo::UpCatch", TclOOUpcatchCmd,
TclOONRUpcatch, NULL, NULL);
Tcl_CreateObjCommand(interp, "::oo::UnknownDefinition",
TclOOUnknownDefinition, NULL, NULL);
- namePtr = Tcl_NewStringObj("::oo::UnknownDefinition", -1);
+ TclNewLiteralStringObj(namePtr, "::oo::UnknownDefinition");
Tcl_SetNamespaceUnknownHandler(interp, fPtr->defineNs, namePtr);
Tcl_SetNamespaceUnknownHandler(interp, fPtr->objdefNs, namePtr);
@@ -292,11 +385,13 @@ InitFoundation(
AllocObject(interp, "::oo::class", NULL));
fPtr->objectCls->thisPtr->selfCls = fPtr->classCls;
fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT;
+ fPtr->objectCls->flags |= ROOT_OBJECT;
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;
TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls);
TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls);
AddRef(fPtr->objectCls->thisPtr);
@@ -314,6 +409,18 @@ InitFoundation(
}
/*
+ * Create the default <cloned> method implementation, used when 'oo::copy'
+ * is called to finish the copying of one object to another.
+ */
+
+ TclNewLiteralStringObj(argsPtr, "originObject");
+ Tcl_IncrRefCount(argsPtr);
+ bodyPtr = Tcl_NewStringObj(clonedBody, -1);
+ TclOONewProcMethod(interp, fPtr->objectCls, 0, fPtr->clonedName, argsPtr,
+ bodyPtr, NULL);
+ Tcl_DecrRefCount(argsPtr);
+
+ /*
* Finish setting up the class of classes by marking the 'new' method as
* private; classes, unlike general objects, must have explicit names. We
* also need to create the constructor for classes.
@@ -323,19 +430,13 @@ InitFoundation(
* that is confusing.
*/
- namePtr = Tcl_NewStringObj("new", -1);
+ TclNewLiteralStringObj(namePtr, "new");
Tcl_NewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr,
namePtr /* keeps ref */, 0 /* ==private */, NULL, NULL);
- argsPtr = Tcl_NewStringObj("{definitionScript {}}", -1);
+ TclNewLiteralStringObj(argsPtr, "{definitionScript {}}");
Tcl_IncrRefCount(argsPtr);
- bodyPtr = Tcl_NewStringObj(
- "set script [list ::oo::define [self] $definitionScript];"
- "lassign [::oo::UpCatch $script] msg opts\n"
- "if {[dict get $opts -code] == 1} {"
- " dict set opts -errorline 0xDeadBeef\n"
- "}\n"
- "return -options $opts $msg", -1);
+ bodyPtr = Tcl_NewStringObj(classConstructorBody, -1);
fPtr->classCls->constructorPtr = TclOONewProcMethod(interp,
fPtr->classCls, 0, NULL, argsPtr, bodyPtr, NULL);
Tcl_DecrRefCount(argsPtr);
@@ -357,6 +458,15 @@ InitFoundation(
NULL);
Tcl_CreateObjCommand(interp, "::oo::copy", TclOOCopyObjectCmd, NULL,NULL);
TclOOInitInfo(interp);
+
+ /*
+ * Now make the class of slots.
+ */
+
+ if (TclOODefineSlots(fPtr) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ return Tcl_Eval(interp, slotScript);
}
/*
@@ -422,6 +532,7 @@ KillFoundation(
Tcl_DecrRefCount(fPtr->unknownMethodNameObj);
Tcl_DecrRefCount(fPtr->constructorName);
Tcl_DecrRefCount(fPtr->destructorName);
+ Tcl_DecrRefCount(fPtr->clonedName);
ckfree(fPtr);
}
@@ -669,8 +780,7 @@ ObjectRenamedTrace(
int flags) /* Why was the object deleted? */
{
Object *oPtr = clientData;
- Class *clsPtr;
- CallContext *contextPtr;
+ Foundation *fPtr = oPtr->fPtr;
/*
* If this is a rename and not a delete of the object, we just flush the
@@ -702,17 +812,20 @@ ObjectRenamedTrace(
*/
AddRef(oPtr);
+ AddRef(fPtr->classCls);
+ AddRef(fPtr->objectCls);
+ AddRef(fPtr->classCls->thisPtr);
+ AddRef(fPtr->objectCls->thisPtr);
oPtr->command = NULL;
- oPtr->flags |= OBJECT_DELETED;
- if (!(oPtr->flags & DESTRUCTOR_CALLED) && (!Tcl_InterpDeleted(interp)
- || (oPtr->flags & (ROOT_OBJECT|ROOT_CLASS)))) {
- contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, 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) {
- int result;
- Tcl_InterpState state;
-
contextPtr->callPtr->flags |= DESTRUCTOR;
contextPtr->skip = 0;
state = Tcl_SaveInterpState(interp, TCL_OK);
@@ -731,25 +844,20 @@ ObjectRenamedTrace(
* and nuke the namespace (which triggers the final crushing of the object
* structure itself).
*
- * The class of classes needs some special care; if it is deleted (and
+ * 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 objects now as well. Due to the incestuous nature of those two
+ * 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)) {
- if ((oPtr->flags & ROOT_OBJECT) && oPtr->fPtr->classCls != NULL) {
- Tcl_DeleteCommandFromToken(interp,
- oPtr->fPtr->classCls->thisPtr->command);
- } else if (oPtr->flags & ROOT_CLASS) {
- oPtr->fPtr->classCls = NULL;
- }
+ if (!Tcl_InterpDeleted(interp) && IsRootObject(oPtr)
+ && !Deleted(fPtr->classCls->thisPtr)) {
+ Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command);
}
- clsPtr = oPtr->classPtr;
- if (clsPtr != NULL) {
- AddRef(clsPtr);
+ if (oPtr->classPtr != NULL) {
+ AddRef(oPtr->classPtr);
ReleaseClassContents(interp, oPtr);
}
@@ -761,9 +869,13 @@ ObjectRenamedTrace(
if (((Namespace *) oPtr->namespacePtr)->earlyDeleteProc != NULL) {
Tcl_DeleteNamespace(oPtr->namespacePtr);
}
- if (clsPtr) {
- DelRef(clsPtr);
+ if (oPtr->classPtr) {
+ DelRef(oPtr->classPtr);
}
+ DelRef(fPtr->classCls->thisPtr);
+ DelRef(fPtr->objectCls->thisPtr);
+ DelRef(fPtr->classCls);
+ DelRef(fPtr->objectCls);
DelRef(oPtr);
}
@@ -783,77 +895,128 @@ ReleaseClassContents(
Tcl_Interp *interp, /* The interpreter containing the class. */
Object *oPtr) /* The object representing the class. */
{
- int i, n;
- Class *clsPtr = oPtr->classPtr, **list;
- Object **insts;
+ FOREACH_HASH_DECLS;
+ int i;
+ Class *clsPtr = oPtr->classPtr, *mixinSubclassPtr, *subclassPtr;
+ Object *instancePtr;
+ Foundation *fPtr = oPtr->fPtr;
/*
- * Must empty list before processing the members of the list so that
- * things happen in the correct order even if something tries to play
- * fast-and-loose.
+ * Sanity check!
*/
- list = clsPtr->mixinSubs.list;
- n = clsPtr->mixinSubs.num;
- clsPtr->mixinSubs.list = NULL;
- clsPtr->mixinSubs.num = 0;
- clsPtr->mixinSubs.size = 0;
- for (i=0 ; i<n ; i++) {
- AddRef(list[i]);
- AddRef(list[i]->thisPtr);
+ 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");
+ }
}
- for (i=0 ; i<n ; i++) {
- if (!(list[i]->thisPtr->flags & OBJECT_DELETED)) {
- list[i]->thisPtr->flags |= OBJECT_DELETED;
- Tcl_DeleteCommandFromToken(interp, list[i]->thisPtr->command);
+
+ /*
+ * 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);
}
- DelRef(list[i]->thisPtr);
- DelRef(list[i]);
}
- if (list != NULL) {
- ckfree(list);
+ FOREACH(subclassPtr, clsPtr->subclasses) {
+ if (subclassPtr != NULL && !IsRoot(subclassPtr)) {
+ AddRef(subclassPtr);
+ AddRef(subclassPtr->thisPtr);
+ }
}
-
- list = clsPtr->subclasses.list;
- n = clsPtr->subclasses.num;
- clsPtr->subclasses.list = NULL;
- clsPtr->subclasses.num = 0;
- clsPtr->subclasses.size = 0;
- for (i=0 ; i<n ; i++) {
- AddRef(list[i]);
- AddRef(list[i]->thisPtr);
+ if (!IsRootClass(oPtr)) {
+ FOREACH(instancePtr, clsPtr->instances) {
+ if (instancePtr != NULL && !IsRoot(instancePtr)) {
+ AddRef(instancePtr);
+ }
+ }
}
- for (i=0 ; i<n ; i++) {
- if (!(list[i]->thisPtr->flags & OBJECT_DELETED)) {
- list[i]->thisPtr->flags |= OBJECT_DELETED;
- Tcl_DeleteCommandFromToken(interp, list[i]->thisPtr->command);
+
+ /*
+ * Squelch classes that this class has been mixed into.
+ */
+
+ FOREACH(mixinSubclassPtr, clsPtr->mixinSubs) {
+ if (mixinSubclassPtr == NULL) {
+ continue;
+ }
+ if (!Deleted(mixinSubclassPtr->thisPtr)) {
+ Tcl_DeleteCommandFromToken(interp,
+ mixinSubclassPtr->thisPtr->command);
}
- DelRef(list[i]->thisPtr);
- DelRef(list[i]);
+ DelRef(mixinSubclassPtr->thisPtr);
+ DelRef(mixinSubclassPtr);
}
- if (list != NULL) {
- ckfree(list);
+ if (clsPtr->mixinSubs.list != NULL) {
+ ckfree(clsPtr->mixinSubs.list);
+ clsPtr->mixinSubs.list = NULL;
+ clsPtr->mixinSubs.num = 0;
}
- insts = clsPtr->instances.list;
- n = clsPtr->instances.num;
- clsPtr->instances.list = NULL;
- clsPtr->instances.num = 0;
- clsPtr->instances.size = 0;
- for (i=0 ; i<n ; i++) {
- AddRef(insts[i]);
+ /*
+ * Squelch subclasses of this class.
+ */
+
+ FOREACH(subclassPtr, clsPtr->subclasses) {
+ if (subclassPtr == NULL || IsRoot(subclassPtr)) {
+ continue;
+ }
+ if (!Deleted(subclassPtr->thisPtr)) {
+ Tcl_DeleteCommandFromToken(interp, subclassPtr->thisPtr->command);
+ }
+ DelRef(subclassPtr->thisPtr);
+ DelRef(subclassPtr);
+ }
+ if (clsPtr->subclasses.list != NULL) {
+ ckfree(clsPtr->subclasses.list);
+ clsPtr->subclasses.list = NULL;
+ clsPtr->subclasses.num = 0;
}
- for (i=0 ; i<n ; i++) {
- if (!(insts[i]->flags & OBJECT_DELETED)) {
- insts[i]->flags |= OBJECT_DELETED;
- Tcl_DeleteCommandFromToken(interp, insts[i]->command);
+
+ /*
+ * Squelch instances of this class (includes objects we're mixed into).
+ */
+
+ if (!IsRootClass(oPtr)) {
+ FOREACH(instancePtr, clsPtr->instances) {
+ if (instancePtr == NULL || IsRoot(instancePtr)) {
+ continue;
+ }
+ if (!Deleted(instancePtr)) {
+ Tcl_DeleteCommandFromToken(interp, instancePtr->command);
+ }
+ DelRef(instancePtr);
}
- DelRef(insts[i]);
}
- if (insts != NULL) {
- ckfree(insts);
+ if (clsPtr->instances.list != NULL) {
+ ckfree(clsPtr->instances.list);
+ clsPtr->instances.list = NULL;
+ clsPtr->instances.num = 0;
+ }
+
+ /*
+ * Special: We delete these after everything else.
+ */
+
+ if (IsRootClass(oPtr) && !Deleted(fPtr->objectCls->thisPtr)) {
+ Tcl_DeleteCommandFromToken(interp, fPtr->objectCls->thisPtr->command);
}
+ /*
+ * Squelch method implementation chain caches.
+ */
+
if (clsPtr->constructorChainPtr) {
TclOODeleteChain(clsPtr->constructorChainPtr);
clsPtr->constructorChainPtr = NULL;
@@ -863,7 +1026,6 @@ ReleaseClassContents(
clsPtr->destructorChainPtr = NULL;
}
if (clsPtr->classChainCache) {
- FOREACH_HASH_DECLS;
CallChain *callPtr;
FOREACH_HASH_VALUE(callPtr, clsPtr->classChainCache) {
@@ -874,6 +1036,10 @@ ReleaseClassContents(
clsPtr->classChainCache = NULL;
}
+ /*
+ * Squelch our filter list.
+ */
+
if (clsPtr->filters.num) {
Tcl_Obj *filterObj;
@@ -884,9 +1050,11 @@ ReleaseClassContents(
clsPtr->filters.num = 0;
}
+ /*
+ * Squelch our metadata.
+ */
if (clsPtr->metadataPtr != NULL) {
- FOREACH_HASH_DECLS;
Tcl_ObjectMetadataType *metadataTypePtr;
ClientData value;
@@ -922,7 +1090,7 @@ ObjectNamespaceDeleted(
Class *clsPtr = oPtr->classPtr, *mixinPtr;
Method *mPtr;
Tcl_Obj *filterObj, *variableObj;
- int i, preserved = !(oPtr->flags & OBJECT_DELETED);
+ int i;
/*
* Instruct everyone to no longer use any allocated fields of the object.
@@ -931,27 +1099,19 @@ ObjectNamespaceDeleted(
* point into freed memory, allowing crashes.
*/
- oPtr->flags |= OBJECT_DELETED;
if (oPtr->command) {
Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command);
}
if (oPtr->myCommand) {
Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myCommand);
}
- if (preserved) {
- AddRef(oPtr);
- if (clsPtr != NULL) {
- AddRef(clsPtr);
- ReleaseClassContents(NULL, oPtr);
- }
- }
/*
* Splice the object out of its context. After this, we must *not* call
* methods on the object.
*/
- if (!(oPtr->flags & ROOT_OBJECT)) {
+ if (!IsRootObject(oPtr)) {
TclOORemoveFromInstances(oPtr, oPtr->selfCls);
}
@@ -1007,11 +1167,10 @@ ObjectNamespaceDeleted(
if (clsPtr != NULL) {
Class *superPtr;
+ Tcl_ObjectMetadataType *metadataTypePtr;
+ ClientData value;
if (clsPtr->metadataPtr != NULL) {
- Tcl_ObjectMetadataType *metadataTypePtr;
- ClientData value;
-
FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) {
metadataTypePtr->deleteProc(value);
}
@@ -1028,7 +1187,7 @@ ObjectNamespaceDeleted(
clsPtr->filters.num = 0;
}
FOREACH(mixinPtr, clsPtr->mixins) {
- if (!(mixinPtr->thisPtr->flags & OBJECT_DELETED)) {
+ if (!Deleted(mixinPtr->thisPtr)) {
TclOORemoveFromMixinSubs(clsPtr, mixinPtr);
}
}
@@ -1037,7 +1196,7 @@ ObjectNamespaceDeleted(
clsPtr->mixins.num = 0;
}
FOREACH(superPtr, clsPtr->superclasses) {
- if (!(superPtr->thisPtr->flags & OBJECT_DELETED)) {
+ if (!Deleted(superPtr->thisPtr)) {
TclOORemoveFromSubclasses(clsPtr, superPtr);
}
}
@@ -1080,12 +1239,6 @@ ObjectNamespaceDeleted(
*/
DelRef(oPtr);
- if (preserved) {
- if (clsPtr) {
- DelRef(clsPtr);
- }
- DelRef(oPtr);
- }
}
/*
@@ -1116,12 +1269,16 @@ TclOORemoveFromInstances(
return;
removeInstance:
- clsPtr->instances.num--;
- if (i < clsPtr->instances.num) {
- clsPtr->instances.list[i] =
- clsPtr->instances.list[clsPtr->instances.num];
+ if (Deleted(clsPtr->thisPtr)) {
+ clsPtr->instances.list[i] = NULL;
+ } else {
+ clsPtr->instances.num--;
+ if (i < clsPtr->instances.num) {
+ clsPtr->instances.list[i] =
+ clsPtr->instances.list[clsPtr->instances.num];
+ }
+ clsPtr->instances.list[clsPtr->instances.num] = NULL;
}
- clsPtr->instances.list[clsPtr->instances.num] = NULL;
}
/*
@@ -1142,6 +1299,9 @@ 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) {
@@ -1182,12 +1342,16 @@ TclOORemoveFromSubclasses(
return;
removeSubclass:
- superPtr->subclasses.num--;
- if (i < superPtr->subclasses.num) {
- superPtr->subclasses.list[i] =
- superPtr->subclasses.list[superPtr->subclasses.num];
+ if (Deleted(superPtr->thisPtr)) {
+ superPtr->subclasses.list[i] = NULL;
+ } else {
+ superPtr->subclasses.num--;
+ if (i < superPtr->subclasses.num) {
+ superPtr->subclasses.list[i] =
+ superPtr->subclasses.list[superPtr->subclasses.num];
+ }
+ superPtr->subclasses.list[superPtr->subclasses.num] = NULL;
}
- superPtr->subclasses.list[superPtr->subclasses.num] = NULL;
}
/*
@@ -1208,6 +1372,9 @@ TclOOAddToSubclasses(
* is assumed that the class is not already
* present as a subclass in the superclass. */
{
+ if (Deleted(superPtr->thisPtr)) {
+ return;
+ }
if (superPtr->subclasses.num >= superPtr->subclasses.size) {
superPtr->subclasses.size += ALLOC_CHUNK;
if (superPtr->subclasses.size == ALLOC_CHUNK) {
@@ -1248,12 +1415,16 @@ TclOORemoveFromMixinSubs(
return;
removeSubclass:
- superPtr->mixinSubs.num--;
- if (i < superPtr->mixinSubs.num) {
- superPtr->mixinSubs.list[i] =
- superPtr->mixinSubs.list[superPtr->mixinSubs.num];
+ if (Deleted(superPtr->thisPtr)) {
+ superPtr->mixinSubs.list[i] = NULL;
+ } else {
+ superPtr->mixinSubs.num--;
+ if (i < superPtr->mixinSubs.num) {
+ superPtr->mixinSubs.list[i] =
+ superPtr->mixinSubs.list[superPtr->mixinSubs.num];
+ }
+ superPtr->mixinSubs.list[superPtr->mixinSubs.num] = NULL;
}
- superPtr->mixinSubs.list[superPtr->mixinSubs.num] = NULL;
}
/*
@@ -1274,6 +1445,9 @@ TclOOAddToMixinSubs(
* is assumed that the class is not already
* present as a subclass in the superclass. */
{
+ if (Deleted(superPtr->thisPtr)) {
+ return;
+ }
if (superPtr->mixinSubs.num >= superPtr->mixinSubs.size) {
superPtr->mixinSubs.size += ALLOC_CHUNK;
if (superPtr->mixinSubs.size == ALLOC_CHUNK) {
@@ -1444,7 +1618,7 @@ Tcl_NewObjectInstance(
TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL);
if (contextPtr != NULL) {
- int result, flags;
+ int result;
Tcl_InterpState state;
state = Tcl_SaveInterpState(interp, TCL_OK);
@@ -1452,7 +1626,6 @@ Tcl_NewObjectInstance(
contextPtr->skip = skip;
result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr,
objc, objv);
- flags = oPtr->flags;
/*
* It's an error if the object was whacked in the constructor.
@@ -1460,7 +1633,7 @@ Tcl_NewObjectInstance(
* errors by accident...) [Bug 2903011]
*/
- if (result != TCL_ERROR && (flags & OBJECT_DELETED)) {
+ if (result != TCL_ERROR && Deleted(oPtr)) {
Tcl_SetResult(interp, "object deleted in constructor",
TCL_STATIC);
Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL);
@@ -1475,7 +1648,7 @@ Tcl_NewObjectInstance(
* bad. [Bug 2903011]
*/
- if (!(flags & OBJECT_DELETED)) {
+ if (!Deleted(oPtr)) {
Tcl_DeleteCommandFromToken(interp, oPtr->command);
}
return NULL;
@@ -1572,6 +1745,7 @@ TclNRNewObjectInstance(
* Fire off the constructors non-recursively.
*/
+ AddRef(oPtr);
TclNRAddCallback(interp, FinalizeAlloc, contextPtr, oPtr, state,
objectPtr);
TclPushTailcallPoint(interp);
@@ -1588,7 +1762,7 @@ FinalizeAlloc(
Object *oPtr = data[1];
Tcl_InterpState state = data[2];
Tcl_Object *objectPtr = data[3];
- int flags = oPtr->flags;
+ //int flags = oPtr->flags;
/*
* It's an error if the object was whacked in the constructor. Force this
@@ -1596,7 +1770,7 @@ FinalizeAlloc(
* [Bug 2903011]
*/
- if (result != TCL_ERROR && (flags & OBJECT_DELETED)) {
+ if (result != TCL_ERROR && Deleted(oPtr)) {
Tcl_SetResult(interp, "object deleted in constructor", TCL_STATIC);
Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL);
result = TCL_ERROR;
@@ -1610,13 +1784,15 @@ FinalizeAlloc(
* 2903011]
*/
- if (!(flags & OBJECT_DELETED)) {
+ if (!Deleted(oPtr)) {
Tcl_DeleteCommandFromToken(interp, oPtr->command);
}
+ DelRef(oPtr);
return TCL_ERROR;
}
Tcl_RestoreInterpState(interp, state);
*objectPtr = (Tcl_Object) oPtr;
+ DelRef(oPtr);
return TCL_OK;
}
@@ -1643,20 +1819,15 @@ Tcl_CopyObjectInstance(
FOREACH_HASH_DECLS;
Method *mPtr;
Class *mixinPtr;
- Tcl_Obj *keyPtr, *filterObj, *variableObj;
- int i;
+ CallContext *contextPtr;
+ Tcl_Obj *keyPtr, *filterObj, *variableObj, *args[3];
+ int i, result;
/*
- * Sanity checks.
+ * Sanity check.
*/
- if (targetName == NULL && oPtr->classPtr != NULL) {
- Tcl_AppendResult(interp, "must supply a name when copying a class",
- NULL);
- Tcl_SetErrorCode(interp, "TCL", "OO", "NO_COPY_TARGET", NULL);
- return NULL;
- }
- if (oPtr->flags & ROOT_CLASS) {
+ if (IsRootClass(oPtr)) {
Tcl_AppendResult(interp, "may not clone the class of classes", NULL);
Tcl_SetErrorCode(interp, "TCL", "OO", "CLONING_CLASS", NULL);
return NULL;
@@ -1728,7 +1899,7 @@ Tcl_CopyObjectInstance(
*/
o2Ptr->flags = oPtr->flags & ~(
- OBJECT_DELETED | ROOT_OBJECT | FILTER_HANDLING);
+ OBJECT_DELETED | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING);
/*
* Copy the object's metadata.
@@ -1879,6 +2050,26 @@ Tcl_CopyObjectInstance(
}
}
+ contextPtr = TclOOGetCallContext(o2Ptr, oPtr->fPtr->clonedName, 0, NULL);
+ if (contextPtr) {
+ args[0] = TclOOObjectName(interp, o2Ptr);
+ args[1] = oPtr->fPtr->clonedName;
+ args[2] = TclOOObjectName(interp, oPtr);
+ Tcl_IncrRefCount(args[0]);
+ Tcl_IncrRefCount(args[1]);
+ Tcl_IncrRefCount(args[2]);
+ result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr, 3,
+ args);
+ TclDecrRefCount(args[0]);
+ TclDecrRefCount(args[1]);
+ TclDecrRefCount(args[2]);
+ TclOODeleteContext(contextPtr);
+ if (result != TCL_OK) {
+ Tcl_DeleteCommandFromToken(interp, o2Ptr->command);
+ return NULL;
+ }
+ }
+
return (Tcl_Object) o2Ptr;
}
@@ -2254,9 +2445,15 @@ TclOOObjectCmdCore(
Tcl_Obj *methodNamePtr;
int result;
+ /*
+ * If we've no method name, throw this directly into the unknown
+ * processing.
+ */
+
if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "method ?arg ...?");
- return TCL_ERROR;
+ flags |= FORCE_UNKNOWN;
+ methodNamePtr = NULL;
+ goto noMapping;
}
/*
@@ -2710,7 +2907,7 @@ int
Tcl_ObjectDeleted(
Tcl_Object object)
{
- return (((Object *)object)->flags & OBJECT_DELETED) ? 1 : 0;
+ return Deleted(object) ? 1 : 0;
}
Tcl_Object