Fix for [7842f33a5c]: Stereotype call chains were ending up bogus in some situations

2 files changed, 128 insertions, 7 deletions

diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c
index aefd921..bfff4e9 100644
--- a/generic/tclOOCall.c
+++ b/generic/tclOOCall.c
@@ -891,15 +891,28 @@ InitCallChain(
     Object *oPtr,
     int flags)
 {
+    /*
+     * Note that it's possible to end up with a NULL oPtr->selfCls here if
+     * there is a call into stereotypical object after it has finished running
+     * its destructor phase. Such things can't be cached for a long time so the
+     * epoch can be bogus. [Bug 7842f33a5c]
+     */
+
     callPtr->flags = flags &
 	    (PUBLIC_METHOD | PRIVATE_METHOD | SPECIAL | FILTER_HANDLING);
     if (oPtr->flags & USE_CLASS_CACHE) {
-	oPtr = oPtr->selfCls->thisPtr;
+	oPtr = (oPtr->selfCls ? oPtr->selfCls->thisPtr : NULL);
 	callPtr->flags |= USE_CLASS_CACHE;
     }
-    callPtr->epoch = oPtr->fPtr->epoch;
-    callPtr->objectCreationEpoch = oPtr->creationEpoch;
-    callPtr->objectEpoch = oPtr->epoch;
+    if (oPtr) {
+	callPtr->epoch = oPtr->fPtr->epoch;
+	callPtr->objectCreationEpoch = oPtr->creationEpoch;
+	callPtr->objectEpoch = oPtr->epoch;
+    } else {
+	callPtr->epoch = 0;
+	callPtr->objectCreationEpoch = 0;
+	callPtr->objectEpoch = 0;
+    }
     callPtr->refCount = 1;
     callPtr->numChain = 0;
     callPtr->chain = callPtr->staticChain;
@@ -930,6 +943,13 @@ IsStillValid(
     int mask)
 {
     if ((oPtr->flags & USE_CLASS_CACHE)) {
+	/*
+	 * If the object is in a weird state (due to stereotype tricks) then
+	 * just declare the cache invalid. [Bug 7842f33a5c]
+	 */
+	if (!oPtr->selfCls) {
+	    return 0;
+	}
 	oPtr = oPtr->selfCls->thisPtr;
 	flags |= USE_CLASS_CACHE;
     }
@@ -1020,8 +1040,16 @@ TclOOGetCallContext(
 	    FreeMethodNameRep(cacheInThisObj);
 	}
 
-	if (oPtr->flags & USE_CLASS_CACHE) {
-	    if (oPtr->selfCls->classChainCache != NULL) {
+	/*
+	 * Note that it's possible to end up with a NULL oPtr->selfCls here if
+	 * there is a call into stereotypical object after it has finished
+	 * running its destructor phase. It's quite a tangle, but at that
+	 * point, we simply can't get stereotypes from the cache.
+	 * [Bug 7842f33a5c]
+	 */
+
+	if (oPtr->flags & USE_CLASS_CACHE && oPtr->selfCls) {
+	    if (oPtr->selfCls->classChainCache) {
 		hPtr = Tcl_FindHashEntry(oPtr->selfCls->classChainCache,
 			(char *) methodNameObj);
 	    } else {
@@ -1226,6 +1254,17 @@ TclOOGetStereotypeCallChain(
     Object obj;
 
     /*
+     * Note that it's possible to end up with a NULL clsPtr here if there is
+     * a call into stereotypical object after it has finished running its
+     * destructor phase. It's quite a tangle, but at that point, we simply
+     * can't get stereotypes. [Bug 7842f33a5c]
+     */
+
+    if (clsPtr == NULL) {
+	return NULL;
+    }
+
+    /*
      * Synthesize a temporary stereotypical object so that we can use existing
      * machinery to produce the stereotypical call chain.
      */
@@ -1448,9 +1487,16 @@ AddSimpleClassChainToCallContext(
      *
      * Note that mixins must be processed before the main class hierarchy.
      * [Bug 1998221]
+     *
+     * Note also that it's possible to end up with a null classPtr here if
+     * there is a call into stereotypical object after it has finished running
+     * its destructor phase. [Bug 7842f33a5c]
      */
 
   tailRecurse:
+    if (classPtr == NULL) {
+	return;
+    }
     FOREACH(superPtr, classPtr->mixins) {
 	AddSimpleClassChainToCallContext(superPtr, methodNameObj, cbPtr,
 		doneFilters, flags|TRAVERSED_MIXIN, filterDecl);
diff --git a/tests/oo.test b/tests/oo.test
index ecd39fd..366f4d3 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -4295,7 +4295,7 @@ test oo-35.6 {
 } -cleanup {
     rename obj {}
 } -result done
-test oo-35.7 {Bug 7842f33a5c: destructor cascading} -setup {
+test oo-35.7.1 {Bug 7842f33a5c: destructor cascading in stereotypes} -setup {
     oo::class create base
     oo::class create RpcClient {
 	superclass base
@@ -4326,6 +4326,81 @@ test oo-35.7 {Bug 7842f33a5c: destructor cascading} -setup {
 } -cleanup {
     base destroy
 } -result {}
+test oo-35.7.2 {Bug 7842f33a5c: destructor cascading in stereotypes} -setup {
+    oo::class create base
+    oo::class create RpcClient {
+	superclass base
+	method write name {
+	    lappend ::result "RpcClient -> $name"
+	}
+	method create_bug {} {
+	    MkObjectRpc create cfg [self] 111
+	}
+	destructor {
+	    lappend ::result "Destroyed"
+	}
+    }
+    oo::class create MkObjectRpc {
+	superclass base
+	variable hdl
+	constructor {rpcHdl mqHdl} {
+	    set hdl $mqHdl
+	    oo::objdefine [self] forward rpc $rpcHdl
+	}
+	destructor {
+	    my rpc write otto-$hdl
+	}
+    }
+    set ::result {}
+} -body {
+    set FH [RpcClient new]
+    $FH create_bug
+    $FH destroy
+    join $result \n
+} -cleanup {
+    base destroy
+} -result {Destroyed}
+test oo-35.7.3 {Bug 7842f33a5c: destructor cascading in stereotypes} -setup {
+    oo::class create base
+    oo::class create RpcClient {
+	superclass base
+	variable interiorObjects
+	method write name {
+	    lappend ::result "RpcClient -> $name"
+	}
+	method create_bug {} {
+	    set obj [MkObjectRpc create cfg [self] 111]
+	    lappend interiorObjects $obj
+	    return $obj
+	}
+	destructor {
+	    lappend ::result "Destroyed"
+	    # Explicit destroy of interior objects
+	    foreach obj $interiorObjects {
+		$obj destroy
+	    }
+	}
+    }
+    oo::class create MkObjectRpc {
+	superclass base
+	variable hdl
+	constructor {rpcHdl mqHdl} {
+	    set hdl $mqHdl
+	    oo::objdefine [self] forward rpc $rpcHdl
+	}
+	destructor {
+	    my rpc write otto-$hdl
+	}
+    }
+    set ::result {}
+} -body {
+    set FH [RpcClient new]
+    $FH create_bug
+    $FH destroy
+    join $result \n
+} -cleanup {
+    base destroy
+} -result "Destroyed\nRpcClient -> otto-111"
 
 
 cleanupTests