Fix [Bug 1786481]

4 files changed, 90 insertions, 22 deletions

diff --git a/ChangeLog b/ChangeLog
index 04b7dda..179c356 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,15 +1,24 @@
+2007-09-08  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclDictObj.c (DictUpdateCmd, DictWithCmd): Plug a hole that
+	* generic/tclExecute.c (TEBC,INST_DICT_UPDATE_END): allowed a careful
+	* tests/dict.test (dict-21.16,21.17,22.11): attacker to craft a dict
+	containing a recursive link to itself, violating one of Tcl's
+	fundamental datatype assumptions and causing a stack crash when the
+	dict was converted to a string. [Bug 1786481]
+
 2007-09-07  Don Porter  <dgp@users.sourceforge.net>
 
 	* generic/tclEvent.c ([::tcl::Bgerror]):	Corrections to Tcl's
 	* tests/event.test:	default [interp bgerror] handler so that when
 	it falls back to a hidden [bgerror] in a safe interp, it gets the
-	right error context data.  [Bug 1790274].
+	right error context data. [Bug 1790274].
 
 2007-09-07  Miguel Sofer  <msofer@users.sf.net>
 
-	* generic/tclProc.c (TclInitCompiledLocals): the refCount of
-	resolved variables was being managed without checking if they were
-	Var or VarInHash: itcl [Bug 1790184]
+	* generic/tclProc.c (TclInitCompiledLocals): the refCount of resolved
+	variables was being managed without checking if they were Var or
+	VarInHash: itcl [Bug 1790184]
 
 2007-09-06  Don Porter  <dgp@users.sourceforge.net>
 
@@ -23,21 +32,21 @@
 2007-09-06  Don Porter  <dgp@users.sourceforge.net>
 
 	* generic/tclInterp.c (Tcl_Init):	Removed constraint on ability
-	to define a custom [tclInit] before calling Tcl_Init().  Until now
-	the custom command had to be a proc.  Now it can be any command.
+	to define a custom [tclInit] before calling Tcl_Init(). Until now the
+	custom command had to be a proc. Now it can be any command.
 
 	* generic/tclInt.decls:	New internal routine TclBackgroundException()
 	* generic/tclEvent.c:	that for the first time permits non-TCL_ERROR
-	exceptions to trigger [interp bgerror] handling.  Closes a gap in
-	TIP 221.  When falling back to [bgerror] (which is designed only
-	to handle TCL_ERROR), convert exceptions into errors complaining
-	about the exception.
+	exceptions to trigger [interp bgerror] handling. Closes a gap in TIP
+	221. When falling back to [bgerror] (which is designed only to handle
+	TCL_ERROR), convert exceptions into errors complaining about the
+	exception.
 
 	* generic/tclInterp.c:	Convert Tcl_BackgroundError() callers to call
 	* generic/tclIO.c:	TclBackgroundException().
 	* generic/tclIOCmd.c:
 	* generic/tclTimer.c:
-	
+
 	* generic/tclIntDecls.h:	make genstubs
 	* generic/tclStubInit.c:
 
@@ -64,14 +73,14 @@
 2007-09-04  Don Porter  <dgp@users.sourceforge.net>
 
 	* unix/Makefile.in:	It's unreliable to count on the release
-	manager to remember to `make genstubs` before `make dist`.  Let the
+	manager to remember to `make genstubs` before `make dist`. Let the
 	Makefile remember the dependency for us.
 
 	* unix/Makefile.in:	Corrections to `make dist` dependencies to be
 	sure that macosx/configure gets generated whenever it does not exist.
 
 2007-09-03  Kevin B, Kenny  <kennykb@acm.org>
-	
+
 	* library/tzdata/Africa/Cairo:
 	* library/tzdata/America/Grand_Turk:
 	* library/tzdata/America/Port-au-Prince:
@@ -88,13 +97,12 @@
 	* library/tzdata/Australia/Sydney:
 	* library/tzdata/Pacific/Auckland:
 	* library/tzdata/Pacific/Chatham: Olson's tzdata2007g.
-	
+
 	* generic/tclListObj.c (TclLindexFlat):
-	* tests/lindex.test (lindex-17.[01]):   Added code to detect the
-	error when a script does [lindex {} end foo]; an overaggressive
-	optimisation caused this call to return an empty object rather
-	than an error.
-	
+	* tests/lindex.test (lindex-17.[01]):   Added code to detect the error
+	when a script does [lindex {} end foo]; an overaggressive optimisation
+	caused this call to return an empty object rather than an error.
+
 2007-09-03  Daniel Steffen  <das@users.sourceforge.net>
 
 	* generic/tclObj.c (TclInitObjSubsystem): restore registration of the
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index 3fa5b65..d8e4165 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -9,7 +9,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclDictObj.c,v 1.49 2007/04/24 20:46:09 dkf Exp $
+ * RCS: @(#) $Id: tclDictObj.c,v 1.50 2007/09/08 22:36:58 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -2744,6 +2744,14 @@ DictUpdateCmd(
 	objPtr = Tcl_ObjGetVar2(interp, objv[i+1], NULL, 0);
 	if (objPtr == NULL) {
 	    Tcl_DictObjRemove(interp, dictPtr, objv[i]);
+	} else if (objPtr == dictPtr) {
+	    /*
+	     * Someone is messing us around, trying to build a recursive
+	     * structure. [Bug 1786481]
+	     */
+
+	    Tcl_DictObjPut(interp, dictPtr, objv[i],
+		    Tcl_DuplicateObj(objPtr));
 	} else {
 	    /* Shouldn't fail */
 	    Tcl_DictObjPut(interp, dictPtr, objv[i], objPtr);
@@ -2915,6 +2923,13 @@ DictWithCmd(
 	valPtr = Tcl_ObjGetVar2(interp, keyv[i], NULL, 0);
 	if (valPtr == NULL) {
 	    Tcl_DictObjRemove(NULL, leafPtr, keyv[i]);
+	} else if (leafPtr == valPtr) {
+	    /*
+	     * Someone is messing us around, trying to build a recursive
+	     * structure. [Bug 1786481]
+	     */
+
+	    Tcl_DictObjPut(NULL, leafPtr, keyv[i], Tcl_DuplicateObj(valPtr));
 	} else {
 	    Tcl_DictObjPut(NULL, leafPtr, keyv[i], valPtr);
 	}
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 52f70a3..87b1024 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -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: tclExecute.c,v 1.329 2007/09/05 21:31:02 dgp Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.330 2007/09/08 22:36:59 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -6724,6 +6724,9 @@ TclExecuteByteCode(
 	    }
 	    if (valPtr == NULL) {
 		Tcl_DictObjRemove(interp, dictPtr, keyPtrPtr[i]);
+	    } else if (dictPtr == valPtr) {
+		Tcl_DictObjPut(interp, dictPtr, keyPtrPtr[i],
+			Tcl_DuplicateObj(valPtr));
 	    } else {
 		Tcl_DictObjPut(interp, dictPtr, keyPtrPtr[i], valPtr);
 	    }
diff --git a/tests/dict.test b/tests/dict.test
index c6e8987..4d3485b 100644
--- a/tests/dict.test
+++ b/tests/dict.test
@@ -9,7 +9,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: dict.test,v 1.20 2007/03/02 10:32:13 dkf Exp $
+# RCS: @(#) $Id: dict.test,v 1.21 2007/09/08 22:36:59 dkf Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2
@@ -1058,6 +1058,35 @@ test dict-21.15 {dict update command: compilation} {
     }
     dicttest {k 1 l 2}
 } {}
+test dict-21.16 {dict update command: no recursive structures [Bug 1786481]} {
+    set foo {a {b {c {d {e 1}}}}}
+    dict update foo a t {
+	dict update t b t {
+	    dict update t c t {
+		dict update t d t {
+		    dict incr t e
+		}
+	    }
+	}
+    }
+    string range [append foo OK] end-1 end
+} OK
+test dict-21.17 {dict update command: no recursive structures [Bug 1786481]} {
+    proc dicttest {} {
+	set foo {a {b {c {d {e 1}}}}}
+	dict update foo a t {
+	    dict update t b t {
+		dict update t c t {
+		    dict update t d t {
+			dict incr t e
+		    }
+		}
+	    }
+	}
+    }
+    dicttest
+    string range [append foo OK] end-1 end
+} OK
 
 test dict-22.1 {dict with command} -body {
     dict with
@@ -1127,6 +1156,19 @@ test dict-22.10 {dict with command: result handling tricky case} {
     }
     list $i $a
 } {0 {}}
+test dict-22.11 {dict with command: no recursive structures [Bug 1786481]} {
+    set foo {t {t {t {inner 1}}}}
+    dict with foo {
+	dict with t {
+	    dict with t {
+		dict with t {
+		    incr inner
+		}
+	    }
+	}
+    }
+    string range [append foo OK] end-1 end
+} OK
 
 # cleanup
 ::tcltest::cleanupTests