summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorMiguel Sofer <miguel.sofer@gmail.com>2005-11-04 01:15:19 (GMT)
committerMiguel Sofer <miguel.sofer@gmail.com>2005-11-04 01:15:19 (GMT)
commitc2f30c4326efeeaff9b28a2015ab079750bfd038 (patch)
tree1c297b8a88c0862a516d74fb05a0ff7d9a955526
parentb6a925833d204aad9696d5bdeb784724a67ea504 (diff)
downloadtcl-c2f30c4326efeeaff9b28a2015ab079750bfd038.zip
tcl-c2f30c4326efeeaff9b28a2015ab079750bfd038.tar.gz
tcl-c2f30c4326efeeaff9b28a2015ab079750bfd038.tar.bz2
* generic/tclInt.h:
* generic/tclNamesp.c: * generic/tclVar.c: fix for [Bugs 1338280/1337229]. Thanks Don. * tests/trace.test: fix duplicate test numbers
-rw-r--r--ChangeLog8
-rw-r--r--generic/tclInt.h3
-rw-r--r--generic/tclNamesp.c8
-rw-r--r--generic/tclVar.c219
-rw-r--r--tests/trace.test6
5 files changed, 189 insertions, 55 deletions
diff --git a/ChangeLog b/ChangeLog
index ad282ba..d657763 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,11 @@
+2005-11-04 Miguel Sofer <msofer@users.sf.net>
+
+ * generic/tclInt.h:
+ * generic/tclNamesp.c:
+ * generic/tclVar.c: fix for [Bugs 1338280/1337229]. Thanks Don.
+
+ * tests/trace.test: fix duplicate test numbers
+
2005-11-03 Don Porter <dgp@users.sourceforge.net>
* generic/tclUnixInit.c (TclpSetInitialEncodings): Modified so
diff --git a/generic/tclInt.h b/generic/tclInt.h
index d2da3b7..60fe1d8 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInt.h,v 1.118.2.18 2005/10/10 21:33:09 hobbs Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.118.2.19 2005/11/04 01:15:20 msofer Exp $
*/
#ifndef _TCLINT
@@ -1652,6 +1652,7 @@ EXTERN int TclArraySet _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj));
EXTERN int TclCheckBadOctal _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *value));
+EXTERN void TclDeleteNamespaceVars _ANSI_ARGS_((Namespace *nsPtr));
EXTERN void TclExpandTokenArray _ANSI_ARGS_((
Tcl_Parse *parsePtr));
EXTERN int TclFileAttrsCmd _ANSI_ARGS_((Tcl_Interp *interp,
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 1f72076..029051c 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -19,7 +19,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclNamesp.c,v 1.31.2.8 2005/07/26 16:20:44 dgp Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.31.2.9 2005/11/04 01:15:20 msofer Exp $
*/
#include "tclInt.h"
@@ -629,7 +629,7 @@ Tcl_DeleteNamespace(namespacePtr)
* variable list one last time.
*/
- TclDeleteVars((Interp *) nsPtr->interp, &nsPtr->varTable);
+ TclDeleteNamespaceVars(nsPtr);
Tcl_DeleteHashTable(&nsPtr->childTable);
Tcl_DeleteHashTable(&nsPtr->cmdTable);
@@ -713,7 +713,7 @@ TclTeardownNamespace(nsPtr)
Tcl_IncrRefCount(errorCode);
}
- TclDeleteVars(iPtr, &nsPtr->varTable);
+ TclDeleteNamespaceVars(nsPtr);
Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS);
if (errorInfo) {
@@ -732,7 +732,7 @@ TclTeardownNamespace(nsPtr)
* frees it, so we reinitialize it afterwards.
*/
- TclDeleteVars(iPtr, &nsPtr->varTable);
+ TclDeleteNamespaceVars(nsPtr);
Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS);
}
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 52fec78..5945bfb 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -15,7 +15,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclVar.c,v 1.69.2.9 2005/10/23 22:01:31 msofer Exp $
+ * RCS: @(#) $Id: tclVar.c,v 1.69.2.10 2005/11/04 01:15:20 msofer Exp $
*/
#include "tclInt.h"
@@ -66,7 +66,9 @@ static void VarErrMsg _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *operation, CONST char *reason));
static int SetArraySearchObj _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
-
+static void UnsetVarStruct _ANSI_ARGS_((Var *varPtr, Var *arrayPtr,
+ Interp *iPtr, CONST char *part1, CONST char *part2,
+ int flags));
/*
* Functions defined in this file that may be exported in the future
@@ -1996,12 +1998,9 @@ TclObjUnsetVar2(interp, part1Ptr, part2, flags)
* TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
* TCL_LEAVE_ERR_MSG. */
{
- Var dummyVar;
- Var *varPtr, *dummyVarPtr;
+ Var *varPtr;
Interp *iPtr = (Interp *) interp;
Var *arrayPtr;
- ActiveVarTrace *activePtr;
- Tcl_Obj *objPtr;
int result;
char *part1;
@@ -2014,11 +2013,106 @@ TclObjUnsetVar2(interp, part1Ptr, part2, flags)
result = (TclIsVarUndefined(varPtr)? TCL_ERROR : TCL_OK);
+ /*
+ * Keep the variable alive until we're done with it. We used to
+ * increase/decrease the refCount for each operation, making it
+ * hard to find [Bug 735335] - caused by unsetting the variable
+ * whose value was the variable's name.
+ */
+
+ varPtr->refCount++;
+
+ UnsetVarStruct(varPtr, arrayPtr, iPtr, part1, part2, flags);
+
+ /*
+ * It's an error to unset an undefined variable.
+ */
+
+ if (result != TCL_OK) {
+ if (flags & TCL_LEAVE_ERR_MSG) {
+ VarErrMsg(interp, part1, part2, "unset",
+ ((arrayPtr == NULL) ? noSuchVar : noSuchElement));
+ }
+ }
+
+ /*
+ * Try to avoid keeping the Var struct allocated due to a tclNsVarNameType
+ * keeping a reference. This removes some additional exteriorisations of
+ * [Bug 736729], but may be a good thing independently of the bug.
+ */
+
+ if (part1Ptr->typePtr == &tclNsVarNameType) {
+ part1Ptr->typePtr->freeIntRepProc(part1Ptr);
+ part1Ptr->typePtr = NULL;
+ }
+
+ /*
+ * Finally, if the variable is truly not in use then free up its Var
+ * structure and remove it from its hash table, if any. The ref count of
+ * its value object, if any, was decremented above.
+ */
+
+ varPtr->refCount--;
+ CleanupVar(varPtr, arrayPtr);
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * UnsetVarStruct --
+ *
+ * Unset and delete a variable. This does the internal work for
+ * TclObjUnsetVar2 and TclDeleteNamespaceVars, which call here for each
+ * variable to be unset and deleted.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * If the arguments indicate a local or global variable in iPtr, it is
+ * unset and deleted.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+UnsetVarStruct(varPtr, arrayPtr, iPtr, part1, part2, flags)
+ Var *varPtr;
+ Var *arrayPtr;
+ Interp *iPtr;
+ CONST char *part1;
+ CONST char *part2;
+ int flags;
+{
+ Var dummyVar;
+ Var *dummyVarPtr;
+ ActiveVarTrace *activePtr;
+
if ((arrayPtr != NULL) && (arrayPtr->searchPtr != NULL)) {
DeleteSearches(arrayPtr);
}
/*
+ * For global/upvar variables referenced in procedures, decrement
+ * the reference count on the variable referred to, and free
+ * the referenced variable if it's no longer needed.
+ */
+
+ if (TclIsVarLink(varPtr)) {
+ Var *linkPtr = varPtr->value.linkPtr;
+ linkPtr->refCount--;
+ if ((linkPtr->refCount == 0) && TclIsVarUndefined(linkPtr)
+ && (linkPtr->tracePtr == NULL)
+ && (linkPtr->flags & VAR_IN_HASHTABLE)) {
+ if (linkPtr->hPtr != NULL) {
+ Tcl_DeleteHashEntry(linkPtr->hPtr);
+ }
+ ckfree((char *) linkPtr);
+ }
+ }
+
+ /*
* The code below is tricky, because of the possibility that
* a trace procedure might try to access a variable being
* deleted. To handle this situation gracefully, do things
@@ -2039,15 +2133,6 @@ TclObjUnsetVar2(interp, part1Ptr, part2, flags)
varPtr->searchPtr = NULL;
/*
- * Keep the variable alive until we're done with it. We used to
- * increase/decrease the refCount for each operation, making it
- * hard to find [Bug 735335] - caused by unsetting the variable
- * whose value was the variable's name.
- */
-
- varPtr->refCount++;
-
- /*
* Call trace procedures for the variable being deleted. Then delete
* its traces. Be sure to abort any other traces for the variable
* that are still pending. Special tricks:
@@ -2104,7 +2189,7 @@ TclObjUnsetVar2(interp, part1Ptr, part2, flags)
}
if (TclIsVarScalar(dummyVarPtr)
&& (dummyVarPtr->value.objPtr != NULL)) {
- objPtr = dummyVarPtr->value.objPtr;
+ Tcl_Obj *objPtr = dummyVarPtr->value.objPtr;
TclDecrRefCount(objPtr);
dummyVarPtr->value.objPtr = NULL;
}
@@ -2118,37 +2203,6 @@ TclObjUnsetVar2(interp, part1Ptr, part2, flags)
varPtr->refCount--;
}
- /*
- * It's an error to unset an undefined variable.
- */
-
- if (result != TCL_OK) {
- if (flags & TCL_LEAVE_ERR_MSG) {
- VarErrMsg(interp, part1, part2, "unset",
- ((arrayPtr == NULL) ? noSuchVar : noSuchElement));
- }
- }
-
- /*
- * Try to avoid keeping the Var struct allocated due to a tclNsVarNameType
- * keeping a reference. This removes some additional exteriorisations of
- * [Bug 736729], but may be a good thing independently of the bug.
- */
-
- if (part1Ptr->typePtr == &tclNsVarNameType) {
- part1Ptr->typePtr->freeIntRepProc(part1Ptr);
- part1Ptr->typePtr = NULL;
- }
-
- /*
- * Finally, if the variable is truly not in use then free up its Var
- * structure and remove it from its hash table, if any. The ref count of
- * its value object, if any, was decremented above.
- */
-
- varPtr->refCount--;
- CleanupVar(varPtr, arrayPtr);
- return result;
}
/*
@@ -4513,6 +4567,77 @@ DeleteSearches(arrayVarPtr)
/*
*----------------------------------------------------------------------
*
+ * TclDeleteNamespaceVars --
+ *
+ * This procedure is called to recycle all the storage space
+ * associated with a namespace's table of variables.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Variables are deleted and trace procedures are invoked, if
+ * any are declared.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclDeleteNamespaceVars(nsPtr)
+ Namespace *nsPtr;
+{
+ Tcl_HashTable *tablePtr = &nsPtr->varTable;
+ Tcl_Interp *interp = nsPtr->interp;
+ Interp *iPtr = (Interp *)interp;
+ Tcl_HashSearch search;
+ Tcl_HashEntry *hPtr;
+ int flags = 0;
+ Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
+
+ /*
+ * Determine what flags to pass to the trace callback procedures.
+ */
+
+ if (nsPtr == iPtr->globalNsPtr) {
+ flags = TCL_GLOBAL_ONLY;
+ } else if (nsPtr == currNsPtr) {
+ flags = TCL_NAMESPACE_ONLY;
+ }
+ if (Tcl_InterpDeleted(interp)) {
+ flags |= TCL_INTERP_DESTROYED;
+ }
+
+ for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
+ hPtr = Tcl_FirstHashEntry(tablePtr, &search)) {
+ register Var *varPtr = (Var *) Tcl_GetHashValue(hPtr);
+ Tcl_Obj *objPtr = Tcl_NewObj();
+ varPtr->refCount++; /* Make sure we get to remove from hash */
+ Tcl_IncrRefCount(objPtr);
+ Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr);
+ UnsetVarStruct(varPtr, NULL, iPtr, Tcl_GetString(objPtr), NULL, flags);
+ Tcl_DecrRefCount(objPtr); /* free no longer needed obj */
+ varPtr->refCount--;
+
+ /* Remove the variable from the table and force it undefined
+ * in case an unset trace brought it back from the dead */
+ Tcl_DeleteHashEntry(hPtr);
+ varPtr->hPtr = NULL;
+ TclSetVarUndefined(varPtr);
+ TclSetVarScalar(varPtr);
+ while (varPtr->tracePtr != NULL) {
+ VarTrace *tracePtr = varPtr->tracePtr;
+ varPtr->tracePtr = tracePtr->nextPtr;
+ Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC);
+ }
+ CleanupVar(varPtr, NULL);
+ }
+ Tcl_DeleteHashTable(tablePtr);
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclDeleteVars --
*
* This procedure is called to recycle all the storage space
diff --git a/tests/trace.test b/tests/trace.test
index c60bc9b..9569ae0 100644
--- a/tests/trace.test
+++ b/tests/trace.test
@@ -11,7 +11,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: trace.test,v 1.26.2.10 2005/10/29 18:44:53 msofer Exp $
+# RCS: @(#) $Id: trace.test,v 1.26.2.11 2005/11/04 01:15:21 msofer Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -1185,12 +1185,12 @@ test trace-18.4 {namespace delete / trace vdelete combo, Bug \#1338280} {
catch {unset x}
catch {unset y}
-test trace-18.3 {trace add command (command existence)} {
+test trace-19.0.1 {trace add command (command existence)} {
# Just in case!
catch {rename nosuchname ""}
list [catch {trace add command nosuchname rename traceCommand} msg] $msg
} {1 {unknown command "nosuchname"}}
-test trace-18.4 {trace add command (command existence in ns)} {
+test trace-19.0.2 {trace add command (command existence in ns)} {
list [catch {trace add command nosuchns::nosuchname rename traceCommand} msg] $msg
} {1 {unknown command "nosuchns::nosuchname"}}