diff options
| -rw-r--r-- | ChangeLog | 12 | ||||
| -rw-r--r-- | generic/tclDictObj.c | 61 | ||||
| -rw-r--r-- | tests/dict.test | 166 |
3 files changed, 219 insertions, 20 deletions
@@ -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 |