summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog12
-rw-r--r--generic/tclDictObj.c61
-rw-r--r--tests/dict.test166
3 files changed, 219 insertions, 20 deletions
diff --git a/ChangeLog b/ChangeLog
index eafe1c2..7c7f167 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,15 @@
+2004-01-14 Donal K. Fellows <donal.k.fellows@man.ac.uk>
+
+ * generic/tclDictObj.c: Assorted dict fixes from Peter Spjuth
+ relating to [Bug 876170].
+ (SetDictFromAny): Make sure that lists retain their ordering even
+ when converted to dictionaries and back.
+ (TraceDictPath): Correct object reference count handling!
+ (DictReplaceCmd, DictRemoveCmd): Stop object leak.
+ (DictIncrCmd,DictLappendCmd,DictAppendCmd,DictSetCmd,DictUnsetCmd):
+ Simpler handling of reference counts when assigning to variables.
+ * tests/dict.test (dict-19.2): Memory leak stress test
+
2004-01-13 Don Porter <dgp@users.sourceforge.net>
* generic/tclCmdMZ.c (Tcl_SwitchObjCmd): Silence compiler warnings.
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index 5fbedd8..5d9fb9a 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.12 2003/12/24 04:18:19 davygrvy Exp $
+ * RCS: @(#) $Id: tclDictObj.c,v 1.13 2004/01/14 09:34:33 dkf Exp $
*/
#include "tclInt.h"
@@ -373,6 +373,15 @@ SetDictFromAny(interp, objPtr)
}
/*
+ * If the list is shared its string rep must not be lost so it
+ * still is the same list.
+ */
+
+ if (Tcl_IsShared(objPtr)) {
+ (void) Tcl_GetString(objPtr);
+ }
+
+ /*
* Build the hash of key/value pairs.
*/
dict = (Dict *) ckalloc(sizeof(Dict));
@@ -594,6 +603,7 @@ TraceDictPath(interp, dictPtr, keyc, keyv, willUpdate)
if (Tcl_IsShared(tmpObj)) {
Tcl_DecrRefCount(tmpObj);
tmpObj = Tcl_DuplicateObj(tmpObj);
+ Tcl_IncrRefCount(tmpObj);
Tcl_SetHashValue(hPtr, (ClientData) tmpObj);
dict->epoch++;
newDict = (Dict *) tmpObj->internalRep.otherValuePtr;
@@ -1355,6 +1365,7 @@ DictReplaceCmd(interp, objc, objv)
{
Tcl_Obj *dictPtr;
int i, result;
+ int allocatedDict = 0;
if ((objc < 3) || !(objc & 1)) {
Tcl_WrongNumArgs(interp, 2, objv, "dictionary ?key value ...?");
@@ -1364,10 +1375,14 @@ DictReplaceCmd(interp, objc, objv)
dictPtr = objv[2];
if (Tcl_IsShared(dictPtr)) {
dictPtr = Tcl_DuplicateObj(dictPtr);
+ allocatedDict = 1;
}
for (i=3 ; i<objc ; i+=2) {
result = Tcl_DictObjPut(interp, dictPtr, objv[i], objv[i+1]);
if (result != TCL_OK) {
+ if (allocatedDict) {
+ Tcl_DecrRefCount(dictPtr);
+ }
return TCL_ERROR;
}
}
@@ -1401,6 +1416,7 @@ DictRemoveCmd(interp, objc, objv)
{
Tcl_Obj *dictPtr;
int i, result;
+ int allocatedDict = 0;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "dictionary ?key ...?");
@@ -1410,10 +1426,14 @@ DictRemoveCmd(interp, objc, objv)
dictPtr = objv[2];
if (Tcl_IsShared(dictPtr)) {
dictPtr = Tcl_DuplicateObj(dictPtr);
+ allocatedDict = 1;
}
for (i=3 ; i<objc ; i++) {
result = Tcl_DictObjRemove(interp, dictPtr, objv[i]);
if (result != TCL_OK) {
+ if (allocatedDict) {
+ Tcl_DecrRefCount(dictPtr);
+ }
return TCL_ERROR;
}
}
@@ -1685,6 +1705,7 @@ DictIncrCmd(interp, objc, objv)
int result, isWide = 0;
long incrValue = 1;
Tcl_WideInt wideIncrValue = 0;
+ int allocatedDict = 0;
if (objc < 4 || objc > 5) {
Tcl_WrongNumArgs(interp, 2, objv, "varName key ?increment?");
@@ -1714,6 +1735,7 @@ DictIncrCmd(interp, objc, objv)
dictPtr = Tcl_ObjGetVar2(interp, objv[2], NULL, 0);
if (dictPtr == NULL) {
+ allocatedDict = 1;
dictPtr = Tcl_NewDictObj();
if (isWide) {
valuePtr = Tcl_NewWideIntObj(wideIncrValue);
@@ -1726,10 +1748,14 @@ DictIncrCmd(interp, objc, objv)
Tcl_WideInt wValue;
if (Tcl_IsShared(dictPtr)) {
+ allocatedDict = 1;
dictPtr = Tcl_DuplicateObj(dictPtr);
}
if (Tcl_DictObjGet(interp, dictPtr, objv[3], &valuePtr) != TCL_OK) {
+ if (allocatedDict) {
+ Tcl_DecrRefCount(dictPtr);
+ }
return TCL_ERROR;
}
if (valuePtr == NULL) {
@@ -1785,6 +1811,9 @@ DictIncrCmd(interp, objc, objv)
*/
result = Tcl_GetWideIntFromObj(interp, valuePtr, &wValue);
if (result != TCL_OK) {
+ if (allocatedDict) {
+ Tcl_DecrRefCount(dictPtr);
+ }
return result;
}
/*
@@ -1818,15 +1847,23 @@ DictIncrCmd(interp, objc, objv)
}
}
if (Tcl_DictObjPut(interp, dictPtr, objv[3], valuePtr) != TCL_OK) {
+ /*
+ * This shouldn't happen since dictPtr is known
+ * from above to be a valid dictionary.
+ */
+ if (allocatedDict) {
+ Tcl_DecrRefCount(dictPtr);
+ }
Tcl_DecrRefCount(valuePtr);
return TCL_ERROR;
}
}
valueAlreadyInDictionary:
+ Tcl_IncrRefCount(dictPtr);
resultPtr = Tcl_ObjSetVar2(interp, objv[2], NULL, dictPtr,
TCL_LEAVE_ERR_MSG);
+ Tcl_DecrRefCount(dictPtr);
if (resultPtr == NULL) {
- Tcl_DecrRefCount(dictPtr);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, resultPtr);
@@ -1910,12 +1947,11 @@ DictLappendCmd(interp, objc, objv)
Tcl_InvalidateStringRep(dictPtr);
}
+ Tcl_IncrRefCount(dictPtr);
resultPtr = Tcl_ObjSetVar2(interp, objv[2], NULL, dictPtr,
TCL_LEAVE_ERR_MSG);
+ Tcl_DecrRefCount(dictPtr);
if (resultPtr == NULL) {
- if (allocatedDict) {
- Tcl_DecrRefCount(dictPtr);
- }
return TCL_ERROR;
}
Tcl_SetObjResult(interp, resultPtr);
@@ -1984,12 +2020,11 @@ DictAppendCmd(interp, objc, objv)
Tcl_DictObjPut(interp, dictPtr, objv[3], valuePtr);
+ Tcl_IncrRefCount(dictPtr);
resultPtr = Tcl_ObjSetVar2(interp, objv[2], NULL, dictPtr,
TCL_LEAVE_ERR_MSG);
+ Tcl_DecrRefCount(dictPtr);
if (resultPtr == NULL) {
- if (allocatedDict) {
- Tcl_DecrRefCount(dictPtr);
- }
return TCL_ERROR;
}
Tcl_SetObjResult(interp, resultPtr);
@@ -2188,12 +2223,11 @@ DictSetCmd(interp, objc, objv)
return TCL_ERROR;
}
+ Tcl_IncrRefCount(dictPtr);
resultPtr = Tcl_ObjSetVar2(interp, objv[2], NULL, dictPtr,
TCL_LEAVE_ERR_MSG);
+ Tcl_DecrRefCount(dictPtr);
if (resultPtr == NULL) {
- if (allocatedDict) {
- Tcl_DecrRefCount(dictPtr);
- }
return TCL_ERROR;
}
Tcl_SetObjResult(interp, resultPtr);
@@ -2249,12 +2283,11 @@ DictUnsetCmd(interp, objc, objv)
return TCL_ERROR;
}
+ Tcl_IncrRefCount(dictPtr);
resultPtr = Tcl_ObjSetVar2(interp, objv[2], NULL, dictPtr,
TCL_LEAVE_ERR_MSG);
+ Tcl_DecrRefCount(dictPtr);
if (resultPtr == NULL) {
- if (allocatedDict) {
- Tcl_DecrRefCount(dictPtr);
- }
return TCL_ERROR;
}
Tcl_SetObjResult(interp, resultPtr);
diff --git a/tests/dict.test b/tests/dict.test
index e4d5994..c7ea06d 100644
--- a/tests/dict.test
+++ b/tests/dict.test
@@ -9,13 +9,16 @@
# 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.4 2003/10/06 14:32:22 dgp Exp $
+# RCS: @(#) $Id: dict.test,v 1.5 2004/01/14 09:34:33 dkf Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
+# Used for constraining memory leak tests
+testConstraint memory [llength [info commands memory]]
+
# Procedure to help check the contents of a dictionary. Note that we
# can't just compare the string version because the order of the
# elements is (deliberately) not defined. This is because it is
@@ -64,11 +67,11 @@ test dict-2.5 {dict create command} {
} {1 {wrong # args: should be "dict create ?key value ...?"}}
test dict-2.6 {dict create command - initialse refcount field!} {
# Bug 715751 will show up in memory debuggers like purify
- for {set i 0} {$i<10} {incr i} {
- set dictv [dict create a 0]
- set share [dict values $dictv]
- list [dict incr dictv a]
- }
+ for {set i 0} {$i<10} {incr i} {
+ set dictv [dict create a 0]
+ set share [dict values $dictv]
+ list [dict incr dictv a]
+ }
} {}
test dict-2.7 {dict create command - #-quoting in string rep} {
dict create # #comment
@@ -136,6 +139,7 @@ test dict-4.8 {dict replace command} {
list [catch {dict replace [list a a a] a b} msg] $msg
} {1 {missing value to go with key}}
test dict-4.9 {dict replace command} {dict replace [list a a] a b} {a b}
+test dict-4.10 {dict replace command} {dict replace [list a a] a b a c} {a c}
test dict-5.1 {dict remove command} {dict remove {a b c d} a} {c d}
test dict-5.2 {dict remove command} {dict remove {a b c d} c} {a b}
@@ -711,6 +715,156 @@ test dict-17.23 {dict filter command} {
list [catch {dict filter a key *} msg] $msg
} {1 {missing value to go with key}}
+test dict-18.1 {dict-list relationship} {
+ -body {
+ # Test that any internal conversion between list and dict
+ # does not change the object
+ set l [list 1 2 3 4 5 6 7 8 9 0 q w e r t y]
+ dict values $l
+ set l
+ }
+ -result {1 2 3 4 5 6 7 8 9 0 q w e r t y}
+}
+test dict-18.2 {dict-list relationship} {
+ -body {
+ # Test that the dictionary is a valid list
+ set d [dict create "abc def" 0 "a\{b" 1 "c\}d" 2]
+ for {set t 0} {$t < 5} {incr t} {
+ llength $d
+ dict lappend d "abc def" "\}\{"
+ dict append d "a\{b" "\}"
+ dict incr d "c\}d" 1
+ }
+ llength $d
+ }
+ -result 6
+}
+
+# This is a test for a specific bug.
+# It shows a bad ref counter when running with memdebug on.
+test dict-19.1 {memory bug} -setup {
+ proc xxx {} {
+ set successors [dict create x {c d}]
+ dict set successors x a b
+ dict get $successors x
+ }
+} -body {
+ xxx
+} -cleanup {
+ rename xxx {}
+} -result [dict create c d a b]
+test dict-19.2 {dict: testing for leaks} -setup {
+ proc getbytes {} {
+ set lines [split [memory info] "\n"]
+ lindex [lindex $lines 3] 3
+ }
+ # This test is made to stress object reference management
+ proc stress {} {
+ # A shared invalid dictinary
+ set apa {a {}b c d}
+ set bepa $apa
+ catch {dict replace $apa e f}
+ catch {dict remove $apa c d}
+ catch {dict incr apa a 5}
+ catch {dict lappend apa a 5}
+ catch {dict append apa a 5}
+ catch {dict set apa a 5}
+ catch {dict unset apa a}
+
+ # A shared valid dictionary, invalid incr
+ set apa {a b c d}
+ set bepa $apa
+ catch {dict incr bepa a 5}
+
+ # An error during write to an unshared object, incr
+ set apa {a 1 b 2}
+ set bepa [lrange $apa 0 end]
+ trace add variable bepa write {error hej}
+ catch {dict incr bepa a 5}
+ unset bepa
+
+ # An error during write to a shared object, incr
+ set apa {a 1 b 2}
+ set bepa $apa
+ trace add variable bepa write {error hej}
+ catch {dict incr bepa a 5}
+ unset bepa
+
+ # A shared valid dictionary, invalid lappend
+ set apa [list a {{}b} c d]
+ set bepa $apa
+ catch {dict lappend bepa a 5}
+
+ # An error during write to an unshared object, lappend
+ set apa {a 1 b 2}
+ set bepa [lrange $apa 0 end]
+ trace add variable bepa write {error hej}
+ catch {dict lappend bepa a 5}
+ unset bepa
+
+ # An error during write to a shared object, lappend
+ set apa {a 1 b 2}
+ set bepa $apa
+ trace add variable bepa write {error hej}
+ catch {dict lappend bepa a 5}
+ unset bepa
+
+ # An error during write to an unshared object, append
+ set apa {a 1 b 2}
+ set bepa [lrange $apa 0 end]
+ trace add variable bepa write {error hej}
+ catch {dict append bepa a 5}
+ unset bepa
+
+ # An error during write to a shared object, append
+ set apa {a 1 b 2}
+ set bepa $apa
+ trace add variable bepa write {error hej}
+ catch {dict append bepa a 5}
+ unset bepa
+
+ # An error during write to an unshared object, set
+ set apa {a 1 b 2}
+ set bepa [lrange $apa 0 end]
+ trace add variable bepa write {error hej}
+ catch {dict set bepa a 5}
+ unset bepa
+
+ # An error during write to a shared object, set
+ set apa {a 1 b 2}
+ set bepa $apa
+ trace add variable bepa write {error hej}
+ catch {dict set bepa a 5}
+ unset bepa
+
+ # An error during write to an unshared object, unset
+ set apa {a 1 b 2}
+ set bepa [lrange $apa 0 end]
+ trace add variable bepa write {error hej}
+ catch {dict unset bepa a}
+ unset bepa
+
+ # An error during write to a shared object, unset
+ set apa {a 1 b 2}
+ set bepa $apa
+ trace add variable bepa write {error hej}
+ catch {dict unset bepa a}
+ unset bepa
+ }
+} -constraints memory -body {
+ set end [getbytes]
+ for {set i 0} {$i < 5} {incr i} {
+ stress
+ set tmp $end
+ set end [getbytes]
+ }
+ expr {$end - $tmp}
+} -cleanup {
+ unset -nocomplain end i tmp
+ rename getbytes {}
+ rename stress {}
+} -result 0
+
# cleanup
::tcltest::cleanupTests
return