From 20baf86d1e03655bb6d7fae562091e95fe52db15 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 28 Mar 2016 21:24:22 +0000 Subject: The DupEncodingIntRep() routine is broken. It fails to set the typePtr field of the duplicated Tcl_Obj to indicate that the intrep is that of the &encodingType. The impact must be that refcounting of Tcl_Encodings are out of balance, at least in the (unusual?) case where "encoding" values need duplication. I hesitate to actually commit this fix until I have a test demonstrating the need for it, and a chance to see the impact on actual encoding operations. The lifetime management of encodings has a history of being tricky and raising controversy. More work required. --- generic/tclEncoding.c | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 4edebcf..32055a3 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -355,6 +355,7 @@ DupEncodingIntRep( Tcl_Obj *dupPtr) { dupPtr->internalRep.twoPtrValue.ptr1 = Tcl_GetEncoding(NULL, srcPtr->bytes); + dupPtr->typePtr = &encodingType; } /* -- cgit v0.12 From b87ec263c780440f2e79ab29f3dea7a4bf02ba1d Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 6 May 2016 16:03:15 +0000 Subject: Bug fix. Have to arrange to only close a catch once. After the space has been returned to placeholder values, closing with them as data leads to memory corruption. There's probably a better fix available because the error here feels like it's rooted somewhere else, having us continue to check values we ought to know have already been closed. --- generic/tclAssembly.c | 3 +++ 1 file changed, 3 insertions(+) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 6d5676b..d02721d 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -3984,6 +3984,9 @@ UnstackExpiredCatches( while (catchDepth > bbPtr->catchDepth) { --catchDepth; + if (catches[catchDepth] == NULL) { + continue; + } range = envPtr->exceptArrayPtr + catchIndices[catchDepth]; range->numCodeBytes = bbPtr->startOffset - range->codeOffset; catches[catchDepth] = NULL; -- cgit v0.12 From 88a98003bf03a290ae31656870efb11b2588d0cd Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 13 May 2016 07:49:50 +0000 Subject: Make tclreg13.dll work in any Unicode environment (either with 32-bit or 64-bit characters). Adopted from Androwish. Thanks to Christian Werner. version -> 1.3.2 --- library/reg/pkgIndex.tcl | 4 ++-- tests/registry.test | 4 ++-- win/Makefile.in | 4 ++-- win/makefile.vc | 4 ++-- win/tclWinReg.c | 28 ++++++++++++++++------------ 5 files changed, 24 insertions(+), 20 deletions(-) diff --git a/library/reg/pkgIndex.tcl b/library/reg/pkgIndex.tcl index 49fd1ac..b1fe234 100755 --- a/library/reg/pkgIndex.tcl +++ b/library/reg/pkgIndex.tcl @@ -1,9 +1,9 @@ if {([info commands ::tcl::pkgconfig] eq "") || ([info sharedlibextension] ne ".dll")} return if {[::tcl::pkgconfig get debug]} { - package ifneeded registry 1.3.1 \ + package ifneeded registry 1.3.2 \ [list load [file join $dir tclreg13g.dll] registry] } else { - package ifneeded registry 1.3.1 \ + package ifneeded registry 1.3.2 \ [list load [file join $dir tclreg13.dll] registry] } diff --git a/tests/registry.test b/tests/registry.test index 0f78212..2072559 100644 --- a/tests/registry.test +++ b/tests/registry.test @@ -19,7 +19,7 @@ testConstraint reg 0 if {[testConstraint win]} { if {![catch { ::tcltest::loadTestedCommands - set ::regver [package require registry 1.3.1] + set ::regver [package require registry 1.3.2] }]} { testConstraint reg 1 } @@ -33,7 +33,7 @@ testConstraint english [expr { test registry-1.0 {check if we are testing the right dll} {win reg} { set ::regver -} {1.3.1} +} {1.3.2} test registry-1.1 {argument parsing for registry command} {win reg} { list [catch {registry} msg] $msg } {1 {wrong # args: should be "registry ?-32bit|-64bit? option ?arg ...?"}} diff --git a/win/Makefile.in b/win/Makefile.in index 2d27a41..cf72e1c 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -713,14 +713,14 @@ test-tcl: binaries $(TCLSH) $(CAT32) $(TEST_DLL_FILE) ./$(TCLSH) "$(ROOT_DIR_NATIVE)/tests/all.tcl" $(TESTFLAGS) \ -load "package ifneeded Tcltest ${VERSION}@TCL_PATCH_LEVEL@ [list load [file normalize ${TEST_DLL_FILE}] Tcltest]; \ package ifneeded dde 1.4.0 [list load [file normalize ${DDE_DLL_FILE}] dde]; \ - package ifneeded registry 1.3.1 [list load [file normalize ${REG_DLL_FILE}] registry]" | ./$(CAT32) + package ifneeded registry 1.3.2 [list load [file normalize ${REG_DLL_FILE}] registry]" | ./$(CAT32) # Useful target to launch a built tclsh with the proper path,... runtest: binaries $(TCLSH) $(TEST_DLL_FILE) @TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ ./$(TCLSH) $(TESTFLAGS) -load "package ifneeded Tcltest ${VERSION}@TCL_PATCH_LEVEL@ [list load [file normalize ${TEST_DLL_FILE}] Tcltest]; \ package ifneeded dde 1.4.0 [list load [file normalize ${DDE_DLL_FILE}] dde]; \ - package ifneeded registry 1.3.1 [list load [file normalize ${REG_DLL_FILE}] registry]" $(SCRIPT) + package ifneeded registry 1.3.2 [list load [file normalize ${REG_DLL_FILE}] registry]" $(SCRIPT) # This target can be used to run tclsh from the build directory via # `make shell SCRIPT=foo.tcl` diff --git a/win/makefile.vc b/win/makefile.vc index ecfcecf..eb9a594 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -589,13 +589,13 @@ test-core: setup $(TCLTEST) dlls $(CAT32) !if "$(OS)" == "Windows_NT" || "$(MSVCDIR)" == "IDE" $(DEBUGGER) $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << package ifneeded dde 1.4.0 [list load "$(TCLDDELIB:\=/)" dde] - package ifneeded registry 1.3.1 [list load "$(TCLREGLIB:\=/)" registry] + package ifneeded registry 1.3.2 [list load "$(TCLREGLIB:\=/)" registry] << !else @echo Please wait while the tests are collected... $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << > tests.log package ifneeded dde 1.4.0 "$(TCLDDELIB:\=/)" dde] - package ifneeded registry 1.3.1 "$(TCLREGLIB:\=/)" registry] + package ifneeded registry 1.3.2 "$(TCLREGLIB:\=/)" registry] << type tests.log | more !endif diff --git a/win/tclWinReg.c b/win/tclWinReg.c index 56aa991..a3bcc81 100644 --- a/win/tclWinReg.c +++ b/win/tclWinReg.c @@ -163,7 +163,7 @@ Registry_Init( cmd = Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd, interp, DeleteCmd); Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, cmd); - return Tcl_PkgProvide(interp, "registry", "1.3.1"); + return Tcl_PkgProvide(interp, "registry", "1.3.2"); } /* @@ -803,17 +803,17 @@ GetValue( * we get bogus data. */ - while ((p < end) && *((Tcl_UniChar *) p) != 0) { - Tcl_UniChar *up; + while ((p < end) && *((WCHAR *) p) != 0) { + WCHAR *wp; Tcl_WinTCharToUtf((TCHAR *) p, -1, &buf); Tcl_ListObjAppendElement(interp, resultPtr, Tcl_NewStringObj(Tcl_DStringValue(&buf), Tcl_DStringLength(&buf))); - up = (Tcl_UniChar *) p; + wp = (WCHAR *) p; - while (*up++ != 0) {/* empty body */} - p = (char *) up; + while (*wp++ != 0) {/* empty body */} + p = (char *) wp; Tcl_DStringFree(&buf); } Tcl_SetObjResult(interp, resultPtr); @@ -1332,7 +1332,7 @@ SetValue( data = (char *) Tcl_WinUtfToTChar(data, length, &buf); /* - * Include the null in the length, padding if needed for Unicode. + * Include the null in the length, padding if needed for WCHAR. */ Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1); @@ -1393,9 +1393,10 @@ BroadcastValue( DWORD_PTR sendResult; int timeout = 3000; size_t len; - int unilen; const char *str; Tcl_Obj *objPtr; + WCHAR *wstr; + Tcl_DString ds; if (objc == 3) { str = Tcl_GetString(objv[1]); @@ -1408,9 +1409,11 @@ BroadcastValue( } } - str = (char*)Tcl_GetUnicodeFromObj(objv[0], &unilen); - if (unilen == 0) { - str = NULL; + str = Tcl_GetString(objv[0]); + len = objv[0]->length; + wstr = (WCHAR *) Tcl_WinUtfToTChar(str, len, &ds); + if (Tcl_DStringLength(&ds) == 0) { + wstr = NULL; } /* @@ -1418,7 +1421,8 @@ BroadcastValue( */ result = SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, - (WPARAM) 0, (LPARAM) str, SMTO_ABORTIFHUNG, (UINT) timeout, &sendResult); + (WPARAM) 0, (LPARAM) wstr, SMTO_ABORTIFHUNG, (UINT) timeout, &sendResult); + Tcl_DStringFree(&ds); objPtr = Tcl_NewObj(); Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewLongObj((long) result)); -- cgit v0.12 From 79cda12010d970f8602ad38d1adbb788b1a7888e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 13 May 2016 09:07:43 +0000 Subject: result/sendResult could be 64-bit, so account for that --- win/tclWinReg.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/win/tclWinReg.c b/win/tclWinReg.c index a3bcc81..5f7fd31 100644 --- a/win/tclWinReg.c +++ b/win/tclWinReg.c @@ -1425,8 +1425,8 @@ BroadcastValue( Tcl_DStringFree(&ds); objPtr = Tcl_NewObj(); - Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewLongObj((long) result)); - Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewLongObj((long) sendResult)); + Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewWideIntObj((Tcl_WideInt) result)); + Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewWideIntObj((Tcl_WideInt) sendResult)); Tcl_SetObjResult(interp, objPtr); return TCL_OK; -- cgit v0.12 From 09ec4a59520b6557298cffe32e679a6733928077 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 14 May 2016 06:38:52 +0000 Subject: Tweak a test to not leave around extra commands. --- tests/assemble.test | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/tests/assemble.test b/tests/assemble.test index 980de68..a9c77e3 100644 --- a/tests/assemble.test +++ b/tests/assemble.test @@ -3281,7 +3281,9 @@ test assemble-51.4 {memory leak testing} memory { } 0 test assemble-52.1 {Bug 3154ea2759} { - proc __BEGIN {} { + apply {{} { + # Needs six exception ranges to force the range allocations to use the + # malloced store. ::tcl::unsupported::assemble { beginCatch @badLabel push error @@ -3291,7 +3293,7 @@ test assemble-52.1 {Bug 3154ea2759} { push 0 jump @okLabel label @badLabel - push 1; # should be pushReturnCode + push 1; # should be pushReturnCode label @okLabel endCatch pop @@ -3304,7 +3306,7 @@ test assemble-52.1 {Bug 3154ea2759} { push 0 jump @okLabel2 label @badLabel2 - push 1; # should be pushReturnCode + push 1; # should be pushReturnCode label @okLabel2 endCatch pop @@ -3317,7 +3319,7 @@ test assemble-52.1 {Bug 3154ea2759} { push 0 jump @okLabel3 label @badLabel3 - push 1; # should be pushReturnCode + push 1; # should be pushReturnCode label @okLabel3 endCatch pop @@ -3330,7 +3332,7 @@ test assemble-52.1 {Bug 3154ea2759} { push 0 jump @okLabel4 label @badLabel4 - push 1; # should be pushReturnCode + push 1; # should be pushReturnCode label @okLabel4 endCatch pop @@ -3343,7 +3345,7 @@ test assemble-52.1 {Bug 3154ea2759} { push 0 jump @okLabel5 label @badLabel5 - push 1; # should be pushReturnCode + push 1; # should be pushReturnCode label @okLabel5 endCatch pop @@ -3356,13 +3358,12 @@ test assemble-52.1 {Bug 3154ea2759} { push 0 jump @okLabel6 label @badLabel6 - push 1; # should be pushReturnCode + push 1; # should be pushReturnCode label @okLabel6 endCatch pop } - } - __BEGIN + }} } {}; # must not crash rename fillTables {} -- cgit v0.12 From dc3841fe45692ab1cda05625f74d951a5a0460d7 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 16 May 2016 10:57:36 +0000 Subject: Possible fix for [f97d4ee020]; uses a two-stage approach to avoid quadratic behaviour. --- generic/tclNamesp.c | 76 +++++++++++++++++++++++++++++++++++++---------------- 1 file changed, 53 insertions(+), 23 deletions(-) diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index dfab185..d286de4 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -1105,8 +1105,6 @@ TclTeardownNamespace( Interp *iPtr = (Interp *) nsPtr->interp; register Tcl_HashEntry *entryPtr; Tcl_HashSearch search; - Tcl_Namespace *childNsPtr; - Tcl_Command cmd; int i; /* @@ -1121,16 +1119,27 @@ TclTeardownNamespace( /* * Delete all commands in this namespace. Be careful when traversing the * hash table: when each command is deleted, it removes itself from the - * command table. - * - * Don't optimize to Tcl_NextHashEntry() because of traces. + * command table. Because of traces (and the desire to avoid the quadratic + * problems of just using Tcl_FirstHashEntry over and over, [Bug + * f97d4ee020]) we copy to a temporary array and then delete all those + * commands. */ - for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); - entryPtr != NULL; - entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search)) { - cmd = Tcl_GetHashValue(entryPtr); - Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, cmd); + while (nsPtr->cmdTable.numEntries > 0) { + int length = nsPtr->cmdTable.numEntries; + Tcl_Command *cmds = TclStackAlloc((Tcl_Interp *) iPtr, + sizeof(Tcl_Command) * length); + + i = 0; + for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); + entryPtr != NULL; + entryPtr = Tcl_NextHashEntry(&search)) { + cmds[i++] = Tcl_GetHashValue(entryPtr); + } + for (i = 0 ; i < length ; i++) { + Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, cmds[i]); + } + TclStackFree((Tcl_Interp *) iPtr, cmds); } Tcl_DeleteHashTable(&nsPtr->cmdTable); Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS); @@ -1175,25 +1184,46 @@ TclTeardownNamespace( * * BE CAREFUL: When each child is deleted, it will divorce itself from its * parent. You can't traverse a hash table properly if its elements are - * being deleted. We use only the Tcl_FirstHashEntry function to be safe. - * - * Don't optimize to Tcl_NextHashEntry() because of traces. + * being deleted. Because of traces (and the desire to avoid the + * quadratic problems of just using Tcl_FirstHashEntry over and over, [Bug + * f97d4ee020]) we copy to a temporary array and then delete all those + * namespaces. */ #ifndef BREAK_NAMESPACE_COMPAT - for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); - entryPtr != NULL; - entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search)) { - childNsPtr = Tcl_GetHashValue(entryPtr); - Tcl_DeleteNamespace(childNsPtr); + while (nsPtr->childTable.numEntries > 0) { + int length = nsPtr->childTable.numEntries; + Tcl_Namespace **nss = TclStackAlloc((Tcl_Interp *) iPtr, + sizeof(Tcl_Namespace *) * length); + + i = 0; + for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); + entryPtr != NULL; + entryPtr = Tcl_NextHashEntry(&search)) { + nss[i++] = Tcl_GetHashValue(entryPtr); + } + for (i = 0 ; i < length ; i++) { + Tcl_DeleteNamespace(nss[i]); + } + TclStackFree((Tcl_Interp *) iPtr, nss); } #else if (nsPtr->childTablePtr != NULL) { - for (entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search); - entryPtr != NULL; - entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr,&search)) { - childNsPtr = Tcl_GetHashValue(entryPtr); - Tcl_DeleteNamespace(childNsPtr); + while (nsPtr->childTablePtr->numEntries > 0) { + int length = nsPtr->childTablePtr->numEntries; + Tcl_Namespace **nss = TclStackAlloc((Tcl_Interp *) iPtr, + sizeof(Tcl_Namespace *) * length); + + i = 0; + for (entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search); + entryPtr != NULL; + entryPtr = Tcl_NextHashEntry(&search)) { + nss[i++] = Tcl_GetHashValue(entryPtr); + } + for (i = 0 ; i < length ; i++) { + Tcl_DeleteNamespace(nss[i]); + } + TclStackFree((Tcl_Interp *) iPtr, nss); } } #endif -- cgit v0.12 From 07666542f4a7b9ba216e19b1fd3d5db1b3f943c3 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 20 May 2016 05:14:37 +0000 Subject: Added tests that show that this branch isn't ready to be committed back yet. --- tests/namespace.test | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/tests/namespace.test b/tests/namespace.test index cded1f4..1b31fc5 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -2953,6 +2953,25 @@ test namespace-54.1 {leak on namespace deletion} -constraints {memory} \ test namespace-55.1 {compiled ensembles inside compiled ensembles: Bug 6d2f249a01} { info class [format %s constructor] oo::object } "" + +test namespace-56.1 {bug f97d4ee020: mutually-entangled deletion} { + namespace eval ::testing { + proc abc {} {} + proc def {} {} + trace add command abc delete "rename ::testing::def {}; #" + trace add command def delete "rename ::testing::abc {}; #" + } + namespace delete ::testing +} {} +test namespace-56.2 {bug f97d4ee020: mutually-entangled deletion} { + namespace eval ::testing { + namespace eval abc {proc xyz {} {}} + namespace eval def {proc xyz {} {}} + trace add command abc::xyz delete "namespace delete ::testing::def {}; #" + trace add command def::xyz delete "namespace delete ::testing::abc {}; #" + } + namespace delete ::testing +} {} # cleanup catch {rename cmd1 {}} -- cgit v0.12 From f74fa93858b232af77de13991c43775c193df25a Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 21 May 2016 09:26:07 +0000 Subject: Make the tests pass. --- generic/tclNamesp.c | 40 ++++++++++++++++++++++++++-------------- tests/namespace.test | 20 ++++++++++++++++++++ 2 files changed, 46 insertions(+), 14 deletions(-) diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index d286de4..58a86d9 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -1127,17 +1127,21 @@ TclTeardownNamespace( while (nsPtr->cmdTable.numEntries > 0) { int length = nsPtr->cmdTable.numEntries; - Tcl_Command *cmds = TclStackAlloc((Tcl_Interp *) iPtr, - sizeof(Tcl_Command) * length); + Command **cmds = TclStackAlloc((Tcl_Interp *) iPtr, + sizeof(Command *) * length); i = 0; for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&search)) { - cmds[i++] = Tcl_GetHashValue(entryPtr); + cmds[i] = Tcl_GetHashValue(entryPtr); + cmds[i]->refCount++; + i++; } for (i = 0 ; i < length ; i++) { - Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, cmds[i]); + Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, + (Tcl_Command) cmds[i]); + TclCleanupCommandMacro(cmds[i]); } TclStackFree((Tcl_Interp *) iPtr, cmds); } @@ -1188,42 +1192,50 @@ TclTeardownNamespace( * quadratic problems of just using Tcl_FirstHashEntry over and over, [Bug * f97d4ee020]) we copy to a temporary array and then delete all those * namespaces. + * + * Important: leave the hash table itself still live. */ #ifndef BREAK_NAMESPACE_COMPAT while (nsPtr->childTable.numEntries > 0) { int length = nsPtr->childTable.numEntries; - Tcl_Namespace **nss = TclStackAlloc((Tcl_Interp *) iPtr, - sizeof(Tcl_Namespace *) * length); + Namespace **children = TclStackAlloc((Tcl_Interp *) iPtr, + sizeof(Namespace *) * length); i = 0; for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&search)) { - nss[i++] = Tcl_GetHashValue(entryPtr); + children[i] = Tcl_GetHashValue(entryPtr); + children[i]->refCount++; + i++; } for (i = 0 ; i < length ; i++) { - Tcl_DeleteNamespace(nss[i]); + Tcl_DeleteNamespace((Tcl_Namespace *) children[i]); + TclNsDecrRefCount(children[i]); } - TclStackFree((Tcl_Interp *) iPtr, nss); + TclStackFree((Tcl_Interp *) iPtr, children); } #else if (nsPtr->childTablePtr != NULL) { while (nsPtr->childTablePtr->numEntries > 0) { int length = nsPtr->childTablePtr->numEntries; - Tcl_Namespace **nss = TclStackAlloc((Tcl_Interp *) iPtr, - sizeof(Tcl_Namespace *) * length); + Namespace **children = TclStackAlloc((Tcl_Interp *) iPtr, + sizeof(Namespace *) * length); i = 0; for (entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search); entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&search)) { - nss[i++] = Tcl_GetHashValue(entryPtr); + children[i] = Tcl_GetHashValue(entryPtr); + children[i]->refCount++; + i++; } for (i = 0 ; i < length ; i++) { - Tcl_DeleteNamespace(nss[i]); + Tcl_DeleteNamespace((Tcl_Namespace *) children[i]); + TclNsDecrRefCount(children[i]); } - TclStackFree((Tcl_Interp *) iPtr, nss); + TclStackFree((Tcl_Interp *) iPtr, children); } } #endif diff --git a/tests/namespace.test b/tests/namespace.test index 1b31fc5..cb9bc8c 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -2972,6 +2972,26 @@ test namespace-56.2 {bug f97d4ee020: mutually-entangled deletion} { } namespace delete ::testing } {} +test namespace-56.3 {bug f97d4ee020: mutually-entangled deletion} { + namespace eval ::testing { + variable gone {} + oo::class create CB { + variable cmd + constructor other {set cmd $other} + destructor {rename $cmd {}; lappend ::testing::gone $cmd} + } + namespace eval abc { + ::testing::CB create def ::testing::abc::ghi + ::testing::CB create ghi ::testing::abc::def + } + namespace delete abc + try { + return [lsort $gone] + } finally { + namespace delete ::testing + } + } +} {::testing::abc::def ::testing::abc::ghi} # cleanup catch {rename cmd1 {}} -- cgit v0.12