summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--generic/tclAssembly.c10
-rw-r--r--generic/tclCompile.c2
-rw-r--r--generic/tclEncoding.c1
-rw-r--r--generic/tclNamesp.c86
-rwxr-xr-xlibrary/reg/pkgIndex.tcl4
-rw-r--r--tests/assemble.test86
-rw-r--r--tests/namespace.test39
-rw-r--r--tests/registry.test4
-rw-r--r--win/Makefile.in4
-rw-r--r--win/makefile.vc4
-rw-r--r--win/tclWinReg.c32
11 files changed, 223 insertions, 49 deletions
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 4ad31d2..8dd23a0 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -3982,10 +3982,12 @@ UnstackExpiredCatches(
while (catchDepth > bbPtr->catchDepth) {
--catchDepth;
- range = envPtr->exceptArrayPtr + catchIndices[catchDepth];
- range->numCodeBytes = bbPtr->startOffset - range->codeOffset;
- catches[catchDepth] = NULL;
- catchIndices[catchDepth] = -1;
+ if (catches[catchDepth] != NULL) {
+ range = envPtr->exceptArrayPtr + catchIndices[catchDepth];
+ range->numCodeBytes = bbPtr->startOffset - range->codeOffset;
+ catches[catchDepth] = NULL;
+ catchIndices[catchDepth] = -1;
+ }
}
/*
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 96b418c..2042bcc 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -993,7 +993,7 @@ FreeByteCodeInternalRep(
void
TclPreserveByteCode(
- register ByteCode *codePtr)
+ register ByteCode *codePtr)
{
codePtr->refCount++;
}
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;
}
/*
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index dfab185..58a86d9 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,31 @@ 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;
+ 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]->refCount++;
+ i++;
+ }
+ for (i = 0 ; i < length ; i++) {
+ Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr,
+ (Tcl_Command) cmds[i]);
+ TclCleanupCommandMacro(cmds[i]);
+ }
+ TclStackFree((Tcl_Interp *) iPtr, cmds);
}
Tcl_DeleteHashTable(&nsPtr->cmdTable);
Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS);
@@ -1175,25 +1188,54 @@ 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.
+ * 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.
*
- * Don't optimize to Tcl_NextHashEntry() because of traces.
+ * Important: leave the hash table itself still live.
*/
#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;
+ Namespace **children = TclStackAlloc((Tcl_Interp *) iPtr,
+ sizeof(Namespace *) * length);
+
+ i = 0;
+ for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
+ entryPtr != NULL;
+ entryPtr = Tcl_NextHashEntry(&search)) {
+ children[i] = Tcl_GetHashValue(entryPtr);
+ children[i]->refCount++;
+ i++;
+ }
+ for (i = 0 ; i < length ; i++) {
+ Tcl_DeleteNamespace((Tcl_Namespace *) children[i]);
+ TclNsDecrRefCount(children[i]);
+ }
+ TclStackFree((Tcl_Interp *) iPtr, children);
}
#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;
+ Namespace **children = TclStackAlloc((Tcl_Interp *) iPtr,
+ sizeof(Namespace *) * length);
+
+ i = 0;
+ for (entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search);
+ entryPtr != NULL;
+ entryPtr = Tcl_NextHashEntry(&search)) {
+ children[i] = Tcl_GetHashValue(entryPtr);
+ children[i]->refCount++;
+ i++;
+ }
+ for (i = 0 ; i < length ; i++) {
+ Tcl_DeleteNamespace((Tcl_Namespace *) children[i]);
+ TclNsDecrRefCount(children[i]);
+ }
+ TclStackFree((Tcl_Interp *) iPtr, children);
}
}
#endif
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/assemble.test b/tests/assemble.test
index 5c226cd..d17bfd9 100644
--- a/tests/assemble.test
+++ b/tests/assemble.test
@@ -3279,6 +3279,92 @@ test assemble-51.4 {memory leak testing} memory {
}
}
} 0
+
+test assemble-52.1 {Bug 3154ea2759} {
+ apply {{} {
+ # Needs six exception ranges to force the range allocations to use the
+ # malloced store.
+ ::tcl::unsupported::assemble {
+ beginCatch @badLabel
+ push error
+ push testing
+ invokeStk 2
+ pop
+ push 0
+ jump @okLabel
+ label @badLabel
+ push 1; # should be pushReturnCode
+ label @okLabel
+ endCatch
+ pop
+
+ beginCatch @badLabel2
+ push error
+ push testing
+ invokeStk 2
+ pop
+ push 0
+ jump @okLabel2
+ label @badLabel2
+ push 1; # should be pushReturnCode
+ label @okLabel2
+ endCatch
+ pop
+
+ beginCatch @badLabel3
+ push error
+ push testing
+ invokeStk 2
+ pop
+ push 0
+ jump @okLabel3
+ label @badLabel3
+ push 1; # should be pushReturnCode
+ label @okLabel3
+ endCatch
+ pop
+
+ beginCatch @badLabel4
+ push error
+ push testing
+ invokeStk 2
+ pop
+ push 0
+ jump @okLabel4
+ label @badLabel4
+ push 1; # should be pushReturnCode
+ label @okLabel4
+ endCatch
+ pop
+
+ beginCatch @badLabel5
+ push error
+ push testing
+ invokeStk 2
+ pop
+ push 0
+ jump @okLabel5
+ label @badLabel5
+ push 1; # should be pushReturnCode
+ label @okLabel5
+ endCatch
+ pop
+
+ beginCatch @badLabel6
+ push error
+ push testing
+ invokeStk 2
+ pop
+ push 0
+ jump @okLabel6
+ label @badLabel6
+ push 1; # should be pushReturnCode
+ label @okLabel6
+ endCatch
+ pop
+ }
+ }}
+} {}; # must not crash
rename fillTables {}
rename assemble {}
diff --git a/tests/namespace.test b/tests/namespace.test
index 47c8001..5c5783b 100644
--- a/tests/namespace.test
+++ b/tests/namespace.test
@@ -2953,6 +2953,45 @@ 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
+} {}
+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 {}}
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 1368671..9743511 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..5f7fd31 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,11 +1421,12 @@ 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));
- 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;