summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclOOCall.c58
-rw-r--r--tests/oo.test109
-rw-r--r--win/Makefile.in12
3 files changed, 169 insertions, 10 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 8e2cb5f..366f4d3 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -4274,8 +4274,6 @@ test oo-35.5 {Bug 1a56550e96: introspectors must traverse mixin links correctly}
} -cleanup {
base destroy
} -result {{c d e} {c d e}}
-
-
test oo-35.6 {
Bug : teardown of an object that is a class that is an instance of itself
} -setup {
@@ -4297,7 +4295,112 @@ test oo-35.6 {
} -cleanup {
rename obj {}
} -result done
-
+test oo-35.7.1 {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
+ }
+ }
+ 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 {}
+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
diff --git a/win/Makefile.in b/win/Makefile.in
index a325ac3..1a8bd2d 100644
--- a/win/Makefile.in
+++ b/win/Makefile.in
@@ -206,6 +206,7 @@ MKDIR = mkdir -p
SHELL = @SHELL@
RM = rm -f
COPY = cp
+GDB = gdb
CC_SWITCHES = -I"${GENERIC_DIR_NATIVE}" -I"${TOMMATH_DIR_NATIVE}" \
-I"${ZLIB_DIR_NATIVE}" -I"${WIN_DIR_NATIVE}" -DTCL_TOMMATH \
@@ -814,7 +815,16 @@ shell: binaries
# This target can be used to run tclsh inside either gdb or insight
gdb: binaries
@echo "set env TCL_LIBRARY=$(LIBRARY_DIR)" > gdb.run
- gdb ./$(TCLSH) --command=gdb.run
+ $(GDB) ./$(TCLSH) --command=gdb.run
+ rm gdb.run
+
+shquotequote = $(subst ',\",$(subst ",\",$(1)))
+gdb-test: tcltest
+ @printf '%s ' 'set env TCL_LIBRARY=$(LIBRARY_DIR)' > gdb.run
+ @printf '\n' >>gdb.run
+ @printf '%s ' set args $(ROOT_DIR_NATIVE)/tests/all.tcl \
+ $(call shquotequote,$(TESTFLAGS)) -singleproc 1 >> gdb.run
+ $(GDB) ${TEST_EXE_FILE} --command=gdb.run
rm gdb.run
depend:
generated by cgit v0.12 at 2024-09-28 17:26:39 (GMT)