From 96d071af5418655b8dfbecd0410b6e5d07bfbde5 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Wed, 24 Feb 2010 14:30:31 +0000
Subject: Fix some nasties with handling duplicate keys in list->dict->list
 conversions.

---
 ChangeLog            |  5 +++++
 generic/tclDictObj.c | 10 +++++++++-
 generic/tclListObj.c |  8 +++++---
 tests/dict.test      | 18 +++++++++++++++---
 4 files changed, 34 insertions(+), 7 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index c937d2b..c9db0b5 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,10 @@
 2010-02-24  Donal K. Fellows  <dkf@users.sf.net>
 
+	* generic/tclDictObj.c (SetDictFromAny): Prevent the list<->dict
+	* generic/tclListObj.c (SetListFromAny): conversion code from taking
+	too many liberties. Stops loss of duplicate keys in some scenarios.
+	Many thanks to Jean-Claude Wippler for finding this.
+
 	* generic/tclExecute.c (TclExecuteByteCode): Reduce ifdef-fery and
 	size of activation record. More variables shared across instructions
 	than before.
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index dab4418..2751b4a 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.80 2009/11/18 21:59:51 nijtmans Exp $
+ * RCS: @(#) $Id: tclDictObj.c,v 1.81 2010/02/24 14:30:34 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -613,6 +613,14 @@ SetDictFromAny(
 	    if (!isNew) {
 		Tcl_Obj *discardedValue = Tcl_GetHashValue(hPtr);
 
+		/*
+		 * Not really a well-formed dictionary as there are duplicate
+		 * keys, so better get the string rep here so that we can
+		 * convert back.
+		 */
+
+		(void) Tcl_GetString(objPtr);
+
 		TclDecrRefCount(discardedValue);
 	    }
 	    Tcl_SetHashValue(hPtr, objv[i+1]);
diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index 659017c..896dcd3 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -10,7 +10,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclListObj.c,v 1.58 2009/09/30 03:11:26 dgp Exp $
+ * RCS: @(#) $Id: tclListObj.c,v 1.59 2010/02/24 14:30:34 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -1684,10 +1684,12 @@ SetListFromAny(
     /*
      * Dictionaries are a special case; they have a string representation such
      * that *all* valid dictionaries are valid lists. Hence we can convert
-     * more directly.
+     * more directly. Only do this when there's no existing string rep; if
+     * there is, it is the string rep that's authoritative (because it could
+     * describe duplicate keys).
      */
 
-    if (objPtr->typePtr == &tclDictType) {
+    if (objPtr->typePtr == &tclDictType && !objPtr->bytes) {
 	Tcl_Obj *keyPtr, *valuePtr;
 	Tcl_DictSearch search;
 	int done, size;
diff --git a/tests/dict.test b/tests/dict.test
index 7c16c5f..e6b9ba4 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.34 2009/10/29 11:49:25 dkf Exp $
+# RCS: @(#) $Id: dict.test,v 1.35 2010/02/24 14:30:34 dkf Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2
@@ -29,7 +29,7 @@ if {[testConstraint memory]} {
 	expr {$end - $tmp}
     }
 }
-
+
 test dict-1.1 {dict command basic syntax} -returnCodes error -body {
     dict
 } -result {wrong # args: should be "dict subcommand ?arg ...?"}
@@ -938,6 +938,18 @@ test dict-18.2 {dict-list relationship} -body {
 } -cleanup {
     unset d t
 } -result 6
+test dict-18.3 {dict-list relationship} -body {
+    set ld [list a b c d c e f g]
+    list [string length $ld] [dict size $ld] [llength $ld]
+} -cleanup {
+    unset ld
+} -result {15 3 8}
+test dict-18.4 {dict-list relationship} -body {
+    set ld [list a b c d c e f g]
+    list [llength $ld] [dict size $ld] [llength $ld]
+} -cleanup {
+    unset ld
+} -result {8 3 8}
 
 # This is a test for a specific bug.
 # It shows a bad ref counter when running with memdebug on.
@@ -1340,7 +1352,7 @@ test dict-22.11 {dict with command: no recursive structures [Bug 1786481]} -body
 } -cleanup {
     unset foo t inner
 } -result OK
-
+
 # cleanup
 ::tcltest::cleanupTests
 return
-- 
cgit v0.12