summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2007-09-08 22:36:58 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2007-09-08 22:36:58 (GMT)
commit9759bbcba71f400d022a28af45b8fa2a2fe26cc9 (patch)
treee5d893baaa622d3fde69b26c87e513dbb2ece6c1
parent700d951d9c38975ec0ecebf81e041ba444d0806b (diff)
downloadtcl-9759bbcba71f400d022a28af45b8fa2a2fe26cc9.zip
tcl-9759bbcba71f400d022a28af45b8fa2a2fe26cc9.tar.gz
tcl-9759bbcba71f400d022a28af45b8fa2a2fe26cc9.tar.bz2
Fix [Bug 1786481]
-rw-r--r--ChangeLog46
-rw-r--r--generic/tclDictObj.c17
-rw-r--r--generic/tclExecute.c5
-rw-r--r--tests/dict.test44
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