* generic/tclInt.h:

	* generic/tclNamesp.c:
	* generic/tclVar.c: fix for [Bugs 1338280/1337229]. Thanks Don.

	* tests/trace.test: fix duplicate test numbers

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"}}