summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclInt.h1
-rw-r--r--generic/tclNamesp.c134
-rw-r--r--generic/tclZipfs.c3
-rw-r--r--tests/namespace.test32
-rw-r--r--unix/dltest/pkgooa.c7
-rw-r--r--unix/tclXtTest.c3
6 files changed, 119 insertions, 61 deletions
diff --git a/generic/tclInt.h b/generic/tclInt.h
index b8ed3c1..d0c8173 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2958,6 +2958,7 @@ MODULE_SCOPE Tcl_Command TclCreateEnsembleInNs(Tcl_Interp *interp,
const char *name, Tcl_Namespace *nameNamespacePtr,
Tcl_Namespace *ensembleNamespacePtr, int flags);
MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr);
+MODULE_SCOPE void TclDeleteNamespaceChildren(Namespace *nsPtr);
MODULE_SCOPE int TclFindDictElement(Tcl_Interp *interp,
const char *dict, int dictLength,
const char **elementPtr, const char **nextPtr,
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index f57b7e1..99a777e 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -1073,6 +1073,83 @@ TclNamespaceDeleted(
return (nsPtr->flags & NS_DYING) ? 1 : 0;
}
+void
+TclDeleteNamespaceChildren(
+ Namespace *nsPtr /* Namespace whose children to delete */
+)
+{
+ Interp *iPtr = (Interp *) nsPtr->interp;
+ Tcl_HashEntry *entryPtr;
+ int i, unchecked;
+ Tcl_HashSearch search;
+ /*
+ * Delete all the child namespaces.
+ *
+ * BE CAREFUL: When each child is deleted, it divorces itself from its
+ * parent. The hash table can't be proplery traversed if its elements are
+ * being deleted. Because of traces (and the desire to avoid the
+ * quadratic problems of just using Tcl_FirstHashEntry over and over, [Bug
+ * f97d4ee020]) copy to a temporary array and then delete all those
+ * namespaces.
+ *
+ * Important: leave the hash table itself still live.
+ */
+
+#ifndef BREAK_NAMESPACE_COMPAT
+ unchecked = (nsPtr->childTable.numEntries > 0);
+ while (nsPtr->childTable.numEntries > 0 && unchecked) {
+ int length = nsPtr->childTable.numEntries;
+ Namespace **children = (Namespace **)TclStackAlloc((Tcl_Interp *) iPtr,
+ sizeof(Namespace *) * length);
+
+ i = 0;
+ for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
+ entryPtr != NULL;
+ entryPtr = Tcl_NextHashEntry(&search)) {
+ children[i] = (Namespace *)Tcl_GetHashValue(entryPtr);
+ children[i]->refCount++;
+ i++;
+ }
+ unchecked = 0;
+ for (i = 0 ; i < length ; i++) {
+ if (!(children[i]->flags & NS_DYING)) {
+ unchecked = 1;
+ Tcl_DeleteNamespace((Tcl_Namespace *) children[i]);
+ TclNsDecrRefCount(children[i]);
+ }
+ }
+ TclStackFree((Tcl_Interp *) iPtr, children);
+ }
+#else
+ if (nsPtr->childTablePtr != NULL) {
+ unchecked = (nsPtr->childTable.numEntries > 0);
+ while (nsPtr->childTable.numEntries > 0 && unchecked) {
+ int length = nsPtr->childTablePtr->numEntries;
+ Namespace **children = (Namespace **)TclStackAlloc((Tcl_Interp *) iPtr,
+ sizeof(Namespace *) * length);
+
+ i = 0;
+ for (entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search);
+ entryPtr != NULL;
+ entryPtr = Tcl_NextHashEntry(&search)) {
+ children[i] = (Namespace *)Tcl_GetHashValue(entryPtr);
+ children[i]->refCount++;
+ i++;
+ }
+ unchecked = 0;
+ for (i = 0 ; i < length ; i++) {
+ if (!(children[i]->flags & NS_DYING)) {
+ unchecked = 1;
+ Tcl_DeleteNamespace((Tcl_Namespace *) children[i]);
+ TclNsDecrRefCount(children[i]);
+ }
+ }
+ TclStackFree((Tcl_Interp *) iPtr, children);
+ }
+ }
+#endif
+}
+
/*
*----------------------------------------------------------------------
*
@@ -1181,62 +1258,7 @@ TclTeardownNamespace(
nsPtr->commandPathSourceList = NULL;
}
- /*
- * Delete all the child namespaces.
- *
- * 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. 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.
- *
- * Important: leave the hash table itself still live.
- */
-
-#ifndef BREAK_NAMESPACE_COMPAT
- while (nsPtr->childTable.numEntries > 0) {
- int length = nsPtr->childTable.numEntries;
- Namespace **children = (Namespace **)TclStackAlloc((Tcl_Interp *) iPtr,
- sizeof(Namespace *) * length);
-
- i = 0;
- for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
- entryPtr != NULL;
- entryPtr = Tcl_NextHashEntry(&search)) {
- children[i] = (Namespace *)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) {
- while (nsPtr->childTablePtr->numEntries > 0) {
- int length = nsPtr->childTablePtr->numEntries;
- Namespace **children = (Namespace **)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
+ TclDeleteNamespaceChildren(nsPtr);
/*
* Free the namespace's export pattern array.
diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c
index 399aa65..35b6712 100644
--- a/generic/tclZipfs.c
+++ b/generic/tclZipfs.c
@@ -5733,7 +5733,8 @@ ZipfsAppHookFindTclInit(
static void
ZipfsExitHandler(
- TCL_UNUSED(ClientData))
+ TCL_UNUSED(ClientData)
+)
{
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
diff --git a/tests/namespace.test b/tests/namespace.test
index efd00a8..ebc00ab 100644
--- a/tests/namespace.test
+++ b/tests/namespace.test
@@ -3340,6 +3340,38 @@ test namespace-56.5 {Bug 8b9854c3d8} -setup {
} -result 1
+test namespace-56.6 {
+ Namespace deletion traces on both the original routine and the imported
+ routine should run without any memory error under a debug build.
+} -body {
+ variable res 0
+
+ proc ondelete {old new op} {
+ $old
+ }
+
+ namespace eval ns1 {} {
+ namespace export *
+ proc p1 {} {
+ namespace upvar [namespace parent] res res
+ incr res
+ }
+ trace add command p1 delete ondelete
+ }
+
+ namespace eval ns2 {} {
+ namespace import ::ns1::p1
+ trace add command p1 delete ondelete
+ }
+
+ namespace delete ns1
+ namespace delete ns2
+ return $res
+} -cleanup {
+ unset res
+ rename ondelete {}
+} -result 2
+
test namespace-57.0 {
an imported alias should be usable in the deletion trace for the alias
diff --git a/unix/dltest/pkgooa.c b/unix/dltest/pkgooa.c
index ff1cf1f..5aa48a5 100644
--- a/unix/dltest/pkgooa.c
+++ b/unix/dltest/pkgooa.c
@@ -84,10 +84,13 @@ static TclOOStubs stubsCopy = {
NULL, NULL, NULL, NULL, NULL, NULL, NULL,
NULL, NULL, NULL, NULL, NULL, NULL, NULL,
NULL, NULL, NULL, NULL, NULL, NULL, NULL,
- NULL, NULL, NULL, NULL, NULL, NULL, NULL,
+ NULL, NULL, NULL, NULL, NULL, NULL, NULL
+#ifdef Tcl_MethodIsPrivate
+ ,NULL
+#endif
};
-extern DLLEXPORT int
+DLLEXPORT int
Pkgooa_Init(
Tcl_Interp *interp) /* Interpreter in which the package is to be
* made available. */
diff --git a/unix/tclXtTest.c b/unix/tclXtTest.c
index 4ee7cca..882f497 100644
--- a/unix/tclXtTest.c
+++ b/unix/tclXtTest.c
@@ -16,7 +16,6 @@
#include "tcl.h"
static Tcl_ObjCmdProc TesteventloopCmd;
-extern DLLEXPORT Tcl_LibraryInitProc Tclxttest_Init;
/*
* Functions defined in tclXtNotify.c for use by users of the Xt Notifier:
@@ -44,7 +43,7 @@ extern XtAppContext TclSetAppContext(XtAppContext ctx);
*----------------------------------------------------------------------
*/
-int
+DLLEXPORT int
Tclxttest_Init(
Tcl_Interp *interp) /* Interpreter for application. */
{
generated by cgit v0.12 at 2024-11-16 13:19:22 (GMT)