summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2014-06-15 16:14:18 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2014-06-15 16:14:18 (GMT)
commitbe7fffb9163b7fbd88ed6019dd545bc3f48b1a8e (patch)
tree6457838bc52c51ba9d9377f658fe436716ddc50b
parent1839434f32f737c9fb5c3eb0ebec71b3cccfb581 (diff)
parent47711b6d3c66481bf9105074470d52b186c9d53a (diff)
downloadtcl-be7fffb9163b7fbd88ed6019dd545bc3f48b1a8e.zip
tcl-be7fffb9163b7fbd88ed6019dd545bc3f48b1a8e.tar.gz
tcl-be7fffb9163b7fbd88ed6019dd545bc3f48b1a8e.tar.bz2
[1b0266d8bb] Make [dict replace] and [dict remove] have canonicalization semantics close to [lrange] and [lreplace]. [dict merge] is also improved, but is not as strict.
-rw-r--r--generic/tclDictObj.c260
-rw-r--r--generic/tclInt.h4
-rw-r--r--generic/tclUtil.c105
-rw-r--r--tests/dict.test79
4 files changed, 287 insertions, 161 deletions
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index e31d708..9e606f7 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -155,6 +155,13 @@ typedef struct Dict {
} Dict;
/*
+ * Accessor macro for converting between a Tcl_Obj* and a Dict. Note that this
+ * must be assignable as well as readable.
+ */
+
+#define DICT(dictObj) (*((Dict **)&(dictObj)->internalRep.twoPtrValue.ptr1))
+
+/*
* The structure below defines the dictionary object type by means of
* functions that can be invoked by generic object code.
*/
@@ -312,6 +319,7 @@ DeleteChainEntry(
return 0;
} else {
Tcl_Obj *valuePtr = Tcl_GetHashValue(&cPtr->entry);
+
TclDecrRefCount(valuePtr);
}
@@ -361,7 +369,7 @@ DupDictInternalRep(
Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr)
{
- Dict *oldDict = srcPtr->internalRep.twoPtrValue.ptr1;
+ Dict *oldDict = DICT(srcPtr);
Dict *newDict = ckalloc(sizeof(Dict));
ChainEntry *cPtr;
@@ -396,7 +404,7 @@ DupDictInternalRep(
* Store in the object.
*/
- copyPtr->internalRep.twoPtrValue.ptr1 = newDict;
+ DICT(copyPtr) = newDict;
copyPtr->typePtr = &tclDictType;
}
@@ -422,7 +430,7 @@ static void
FreeDictInternalRep(
Tcl_Obj *dictPtr)
{
- Dict *dict = dictPtr->internalRep.twoPtrValue.ptr1;
+ Dict *dict = DICT(dictPtr);
dict->refcount--;
if (dict->refcount <= 0) {
@@ -487,7 +495,7 @@ UpdateStringOfDict(
{
#define LOCAL_SIZE 20
int localFlags[LOCAL_SIZE], *flagPtr = NULL;
- Dict *dict = dictPtr->internalRep.twoPtrValue.ptr1;
+ Dict *dict = DICT(dictPtr);
ChainEntry *cPtr;
Tcl_Obj *keyPtr, *valuePtr;
int i, length, bytesNeeded = 0;
@@ -600,7 +608,7 @@ SetDictFromAny(
Tcl_Obj *objPtr)
{
Tcl_HashEntry *hPtr;
- int isNew, result;
+ int isNew;
Dict *dict = ckalloc(sizeof(Dict));
InitChainTable(dict);
@@ -651,10 +659,9 @@ SetDictFromAny(
const char *elemStart;
int elemSize, literal;
- result = TclFindElement(interp, nextElem, (limit - nextElem),
- &elemStart, &nextElem, &elemSize, &literal);
- if (result != TCL_OK) {
- goto errorExit;
+ if (TclFindDictElement(interp, nextElem, (limit - nextElem),
+ &elemStart, &nextElem, &elemSize, &literal) != TCL_OK) {
+ goto errorInFindDictElement;
}
if (elemStart == limit) {
break;
@@ -673,11 +680,10 @@ SetDictFromAny(
keyPtr->bytes);
}
- result = TclFindElement(interp, nextElem, (limit - nextElem),
- &elemStart, &nextElem, &elemSize, &literal);
- if (result != TCL_OK) {
+ if (TclFindDictElement(interp, nextElem, (limit - nextElem),
+ &elemStart, &nextElem, &elemSize, &literal) != TCL_OK) {
TclDecrRefCount(keyPtr);
- goto errorExit;
+ goto errorInFindDictElement;
}
if (literal) {
@@ -713,7 +719,7 @@ SetDictFromAny(
dict->epoch = 0;
dict->chain = NULL;
dict->refcount = 1;
- objPtr->internalRep.twoPtrValue.ptr1 = dict;
+ DICT(objPtr) = dict;
objPtr->typePtr = &tclDictType;
return TCL_OK;
@@ -723,15 +729,10 @@ SetDictFromAny(
"missing value to go with key", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL);
}
- result = TCL_ERROR;
-
- errorExit:
- if (interp != NULL) {
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL);
- }
+ errorInFindDictElement:
DeleteChainTable(dict);
ckfree(dict);
- return result;
+ return TCL_ERROR;
}
/*
@@ -777,12 +778,11 @@ TclTraceDictPath(
Dict *dict, *newDict;
int i;
- if (dictPtr->typePtr != &tclDictType) {
- if (SetDictFromAny(interp, dictPtr) != TCL_OK) {
- return NULL;
- }
+ if (dictPtr->typePtr != &tclDictType
+ && SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ return NULL;
}
- dict = dictPtr->internalRep.twoPtrValue.ptr1;
+ dict = DICT(dictPtr);
if (flags & DICT_PATH_UPDATE) {
dict->chain = NULL;
}
@@ -818,14 +818,13 @@ TclTraceDictPath(
Tcl_SetHashValue(hPtr, tmpObj);
} else {
tmpObj = Tcl_GetHashValue(hPtr);
- if (tmpObj->typePtr != &tclDictType) {
- if (SetDictFromAny(interp, tmpObj) != TCL_OK) {
- return NULL;
- }
+ if (tmpObj->typePtr != &tclDictType
+ && SetDictFromAny(interp, tmpObj) != TCL_OK) {
+ return NULL;
}
}
- newDict = tmpObj->internalRep.twoPtrValue.ptr1;
+ newDict = DICT(tmpObj);
if (flags & DICT_PATH_UPDATE) {
if (Tcl_IsShared(tmpObj)) {
TclDecrRefCount(tmpObj);
@@ -833,7 +832,7 @@ TclTraceDictPath(
Tcl_IncrRefCount(tmpObj);
Tcl_SetHashValue(hPtr, tmpObj);
dict->epoch++;
- newDict = tmpObj->internalRep.twoPtrValue.ptr1;
+ newDict = DICT(tmpObj);
}
newDict->chain = dictPtr;
@@ -868,7 +867,7 @@ static void
InvalidateDictChain(
Tcl_Obj *dictObj)
{
- Dict *dict = dictObj->internalRep.twoPtrValue.ptr1;
+ Dict *dict = DICT(dictObj);
do {
TclInvalidateStringRep(dictObj);
@@ -878,7 +877,7 @@ InvalidateDictChain(
break;
}
dict->chain = NULL;
- dict = dictObj->internalRep.twoPtrValue.ptr1;
+ dict = DICT(dictObj);
} while (dict != NULL);
}
@@ -916,18 +915,15 @@ Tcl_DictObjPut(
Tcl_Panic("%s called with shared object", "Tcl_DictObjPut");
}
- if (dictPtr->typePtr != &tclDictType) {
- int result = SetDictFromAny(interp, dictPtr);
-
- if (result != TCL_OK) {
- return result;
- }
+ if (dictPtr->typePtr != &tclDictType
+ && SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ return TCL_ERROR;
}
if (dictPtr->bytes != NULL) {
TclInvalidateStringRep(dictPtr);
}
- dict = dictPtr->internalRep.twoPtrValue.ptr1;
+ dict = DICT(dictPtr);
hPtr = CreateChainEntry(dict, keyPtr, &isNew);
Tcl_IncrRefCount(valuePtr);
if (!isNew) {
@@ -970,15 +966,13 @@ Tcl_DictObjGet(
Dict *dict;
Tcl_HashEntry *hPtr;
- if (dictPtr->typePtr != &tclDictType) {
- int result = SetDictFromAny(interp, dictPtr);
- if (result != TCL_OK) {
- *valuePtrPtr = NULL;
- return result;
- }
+ if (dictPtr->typePtr != &tclDictType
+ && SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ *valuePtrPtr = NULL;
+ return TCL_ERROR;
}
- dict = dictPtr->internalRep.twoPtrValue.ptr1;
+ dict = DICT(dictPtr);
hPtr = Tcl_FindHashEntry(&dict->table, keyPtr);
if (hPtr == NULL) {
*valuePtrPtr = NULL;
@@ -1019,18 +1013,16 @@ Tcl_DictObjRemove(
Tcl_Panic("%s called with shared object", "Tcl_DictObjRemove");
}
- if (dictPtr->typePtr != &tclDictType) {
- int result = SetDictFromAny(interp, dictPtr);
- if (result != TCL_OK) {
- return result;
- }
+ if (dictPtr->typePtr != &tclDictType
+ && SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ return TCL_ERROR;
}
- if (dictPtr->bytes != NULL) {
- TclInvalidateStringRep(dictPtr);
- }
- dict = dictPtr->internalRep.twoPtrValue.ptr1;
+ dict = DICT(dictPtr);
if (DeleteChainEntry(dict, keyPtr)) {
+ if (dictPtr->bytes != NULL) {
+ TclInvalidateStringRep(dictPtr);
+ }
dict->epoch++;
}
return TCL_OK;
@@ -1062,14 +1054,12 @@ Tcl_DictObjSize(
{
Dict *dict;
- if (dictPtr->typePtr != &tclDictType) {
- int result = SetDictFromAny(interp, dictPtr);
- if (result != TCL_OK) {
- return result;
- }
+ if (dictPtr->typePtr != &tclDictType
+ && SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ return TCL_ERROR;
}
- dict = dictPtr->internalRep.twoPtrValue.ptr1;
+ dict = DICT(dictPtr);
*sizePtr = dict->table.numEntries;
return TCL_OK;
}
@@ -1116,15 +1106,12 @@ Tcl_DictObjFirst(
Dict *dict;
ChainEntry *cPtr;
- if (dictPtr->typePtr != &tclDictType) {
- int result = SetDictFromAny(interp, dictPtr);
-
- if (result != TCL_OK) {
- return result;
- }
+ if (dictPtr->typePtr != &tclDictType
+ && SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ return TCL_ERROR;
}
- dict = dictPtr->internalRep.twoPtrValue.ptr1;
+ dict = DICT(dictPtr);
cPtr = dict->entryChainHead;
if (cPtr == NULL) {
searchPtr->epoch = -1;
@@ -1299,11 +1286,12 @@ Tcl_DictObjPutKeyList(
return TCL_ERROR;
}
- dict = dictPtr->internalRep.twoPtrValue.ptr1;
+ dict = DICT(dictPtr);
hPtr = CreateChainEntry(dict, keyv[keyc-1], &isNew);
Tcl_IncrRefCount(valuePtr);
if (!isNew) {
Tcl_Obj *oldValuePtr = Tcl_GetHashValue(hPtr);
+
TclDecrRefCount(oldValuePtr);
}
Tcl_SetHashValue(hPtr, valuePtr);
@@ -1355,7 +1343,7 @@ Tcl_DictObjRemoveKeyList(
return TCL_ERROR;
}
- dict = dictPtr->internalRep.twoPtrValue.ptr1;
+ dict = DICT(dictPtr);
DeleteChainEntry(dict, keyv[keyc-1]);
InvalidateDictChain(dictPtr);
return TCL_OK;
@@ -1401,7 +1389,7 @@ Tcl_NewDictObj(void)
dict->epoch = 0;
dict->chain = NULL;
dict->refcount = 1;
- dictPtr->internalRep.twoPtrValue.ptr1 = dict;
+ DICT(dictPtr) = dict;
dictPtr->typePtr = &tclDictType;
return dictPtr;
#endif
@@ -1450,7 +1438,7 @@ Tcl_DbNewDictObj(
dict->epoch = 0;
dict->chain = NULL;
dict->refcount = 1;
- dictPtr->internalRep.twoPtrValue.ptr1 = dict;
+ DICT(dictPtr) = dict;
dictPtr->typePtr = &tclDictType;
return dictPtr;
#else /* !TCL_MEM_DEBUG */
@@ -1504,7 +1492,7 @@ DictCreateCmd(
/*
* The next command is assumed to never fail...
*/
- Tcl_DictObjPut(interp, dictObj, objv[i], objv[i+1]);
+ Tcl_DictObjPut(NULL, dictObj, objv[i], objv[i+1]);
}
Tcl_SetObjResult(interp, dictObj);
return TCL_OK;
@@ -1629,8 +1617,7 @@ DictReplaceCmd(
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr;
- int i, result;
- int allocatedDict = 0;
+ int i;
if ((objc < 2) || (objc & 1)) {
Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?key value ...?");
@@ -1638,18 +1625,18 @@ DictReplaceCmd(
}
dictPtr = objv[1];
+ if (dictPtr->typePtr != &tclDictType
+ && SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ return TCL_ERROR;
+ }
if (Tcl_IsShared(dictPtr)) {
dictPtr = Tcl_DuplicateObj(dictPtr);
- allocatedDict = 1;
+ }
+ if (dictPtr->bytes != NULL) {
+ TclInvalidateStringRep(dictPtr);
}
for (i=2 ; i<objc ; i+=2) {
- result = Tcl_DictObjPut(interp, dictPtr, objv[i], objv[i+1]);
- if (result != TCL_OK) {
- if (allocatedDict) {
- TclDecrRefCount(dictPtr);
- }
- return TCL_ERROR;
- }
+ Tcl_DictObjPut(NULL, dictPtr, objv[i], objv[i+1]);
}
Tcl_SetObjResult(interp, dictPtr);
return TCL_OK;
@@ -1681,8 +1668,7 @@ DictRemoveCmd(
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr;
- int i, result;
- int allocatedDict = 0;
+ int i;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?key ...?");
@@ -1690,18 +1676,18 @@ DictRemoveCmd(
}
dictPtr = objv[1];
+ if (dictPtr->typePtr != &tclDictType
+ && SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ return TCL_ERROR;
+ }
if (Tcl_IsShared(dictPtr)) {
dictPtr = Tcl_DuplicateObj(dictPtr);
- allocatedDict = 1;
+ }
+ if (dictPtr->bytes != NULL) {
+ TclInvalidateStringRep(dictPtr);
}
for (i=2 ; i<objc ; i++) {
- result = Tcl_DictObjRemove(interp, dictPtr, objv[i]);
- if (result != TCL_OK) {
- if (allocatedDict) {
- TclDecrRefCount(dictPtr);
- }
- return TCL_ERROR;
- }
+ Tcl_DictObjRemove(NULL, dictPtr, objv[i]);
}
Tcl_SetObjResult(interp, dictPtr);
return TCL_OK;
@@ -1750,10 +1736,9 @@ DictMergeCmd(
*/
targetObj = objv[1];
- if (targetObj->typePtr != &tclDictType) {
- if (SetDictFromAny(interp, targetObj) != TCL_OK) {
- return TCL_ERROR;
- }
+ if (targetObj->typePtr != &tclDictType
+ && SetDictFromAny(interp, targetObj) != TCL_OK) {
+ return TCL_ERROR;
}
if (objc == 2) {
@@ -1835,12 +1820,9 @@ DictKeysCmd(
* need. [Bug 1705778, leak K04]
*/
- if (objv[1]->typePtr != &tclDictType) {
- int result = SetDictFromAny(interp, objv[1]);
-
- if (result != TCL_OK) {
- return result;
- }
+ if (objv[1]->typePtr != &tclDictType
+ && SetDictFromAny(interp, objv[1]) != TCL_OK) {
+ return TCL_ERROR;
}
if (objc == 3) {
@@ -2056,13 +2038,11 @@ DictInfoCmd(
}
dictPtr = objv[1];
- if (dictPtr->typePtr != &tclDictType) {
- int result = SetDictFromAny(interp, dictPtr);
- if (result != TCL_OK) {
- return result;
- }
+ if (dictPtr->typePtr != &tclDictType
+ && SetDictFromAny(interp, dictPtr) != TCL_OK) {
+ return TCL_ERROR;
}
- dict = dictPtr->internalRep.twoPtrValue.ptr1;
+ dict = DICT(dictPtr);
statsStr = Tcl_HashStats(&dict->table);
Tcl_SetObjResult(interp, Tcl_NewStringObj(statsStr, -1));
@@ -2152,10 +2132,10 @@ DictIncrCmd(
*/
mp_clear(&increment);
- Tcl_DictObjPut(interp, dictPtr, objv[2], objv[3]);
+ Tcl_DictObjPut(NULL, dictPtr, objv[2], objv[3]);
}
} else {
- Tcl_DictObjPut(interp, dictPtr, objv[2], Tcl_NewIntObj(1));
+ Tcl_DictObjPut(NULL, dictPtr, objv[2], Tcl_NewIntObj(1));
}
} else {
/*
@@ -2164,7 +2144,7 @@ DictIncrCmd(
if (Tcl_IsShared(valuePtr)) {
valuePtr = Tcl_DuplicateObj(valuePtr);
- Tcl_DictObjPut(interp, dictPtr, objv[2], valuePtr);
+ Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr);
}
if (objc == 4) {
code = TclIncrObj(interp, valuePtr, objv[3]);
@@ -2173,7 +2153,7 @@ DictIncrCmd(
Tcl_IncrRefCount(incrPtr);
code = TclIncrObj(interp, valuePtr, incrPtr);
- Tcl_DecrRefCount(incrPtr);
+ TclDecrRefCount(incrPtr);
}
}
if (code == TCL_OK) {
@@ -2186,7 +2166,7 @@ DictIncrCmd(
Tcl_SetObjResult(interp, valuePtr);
}
} else if (dictPtr->refCount == 0) {
- Tcl_DecrRefCount(dictPtr);
+ TclDecrRefCount(dictPtr);
}
return code;
}
@@ -2264,7 +2244,7 @@ DictLappendCmd(
}
if (allocatedValue) {
- Tcl_DictObjPut(interp, dictPtr, objv[2], valuePtr);
+ Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr);
} else if (dictPtr->bytes != NULL) {
TclInvalidateStringRep(dictPtr);
}
@@ -2329,17 +2309,15 @@ DictAppendCmd(
if (valuePtr == NULL) {
TclNewObj(valuePtr);
- } else {
- if (Tcl_IsShared(valuePtr)) {
- valuePtr = Tcl_DuplicateObj(valuePtr);
- }
+ } else if (Tcl_IsShared(valuePtr)) {
+ valuePtr = Tcl_DuplicateObj(valuePtr);
}
for (i=3 ; i<objc ; i++) {
Tcl_AppendObjToObj(valuePtr, objv[i]);
}
- Tcl_DictObjPut(interp, dictPtr, objv[2], valuePtr);
+ Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr);
resultPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, dictPtr,
TCL_LEAVE_ERR_MSG);
@@ -2397,6 +2375,7 @@ DictForNRCmd(
if (varc != 2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"must have exactly two variable names", -1));
+ Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "for", NULL);
return TCL_ERROR;
}
searchPtr = TclStackAlloc(interp, sizeof(Tcl_DictSearch));
@@ -2430,12 +2409,14 @@ DictForNRCmd(
*/
Tcl_IncrRefCount(valueObj);
- if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, TCL_LEAVE_ERR_MSG) == NULL) {
+ if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj,
+ TCL_LEAVE_ERR_MSG) == NULL) {
TclDecrRefCount(valueObj);
goto error;
}
TclDecrRefCount(valueObj);
- if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, TCL_LEAVE_ERR_MSG) == NULL) {
+ if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj,
+ TCL_LEAVE_ERR_MSG) == NULL) {
goto error;
}
@@ -2588,6 +2569,7 @@ DictMapNRCmd(
if (varc != 2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"must have exactly two variable names", -1));
+ Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "map", NULL);
return TCL_ERROR;
}
storagePtr = TclStackAlloc(interp, sizeof(DictMapStorage));
@@ -2949,12 +2931,12 @@ DictFilterCmd(
Tcl_DictObjDone(&search);
Tcl_DictObjGet(interp, objv[1], objv[3], &valueObj);
if (valueObj != NULL) {
- Tcl_DictObjPut(interp, resultObj, objv[3], valueObj);
+ Tcl_DictObjPut(NULL, resultObj, objv[3], valueObj);
}
} else {
while (!done) {
if (Tcl_StringMatch(TclGetString(keyObj), pattern)) {
- Tcl_DictObjPut(interp, resultObj, keyObj, valueObj);
+ Tcl_DictObjPut(NULL, resultObj, keyObj, valueObj);
}
Tcl_DictObjNext(&search, &keyObj, &valueObj, &done);
}
@@ -2972,7 +2954,7 @@ DictFilterCmd(
for (i=3 ; i<objc ; i++) {
pattern = TclGetString(objv[i]);
if (Tcl_StringMatch(TclGetString(keyObj), pattern)) {
- Tcl_DictObjPut(interp, resultObj, keyObj, valueObj);
+ Tcl_DictObjPut(NULL, resultObj, keyObj, valueObj);
break; /* stop inner loop */
}
}
@@ -2998,7 +2980,7 @@ DictFilterCmd(
for (i=3 ; i<objc ; i++) {
pattern = TclGetString(objv[i]);
if (Tcl_StringMatch(TclGetString(valueObj), pattern)) {
- Tcl_DictObjPut(interp, resultObj, keyObj, valueObj);
+ Tcl_DictObjPut(NULL, resultObj, keyObj, valueObj);
break; /* stop inner loop */
}
}
@@ -3026,6 +3008,7 @@ DictFilterCmd(
if (varc != 2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"must have exactly two variable names", -1));
+ Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "filter", NULL);
return TCL_ERROR;
}
keyVarObj = varv[0];
@@ -3064,19 +3047,15 @@ DictFilterCmd(
Tcl_IncrRefCount(valueObj);
if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj,
TCL_LEAVE_ERR_MSG) == NULL) {
- Tcl_ResetResult(interp);
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "couldn't set key variable: \"%s\"",
- TclGetString(keyVarObj)));
+ Tcl_AddErrorInfo(interp,
+ "\n (\"dict filter\" filter script key variable)");
result = TCL_ERROR;
goto abnormalResult;
}
if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj,
TCL_LEAVE_ERR_MSG) == NULL) {
- Tcl_ResetResult(interp);
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "couldn't set value variable: \"%s\"",
- TclGetString(valueVarObj)));
+ Tcl_AddErrorInfo(interp,
+ "\n (\"dict filter\" filter script value variable)");
result = TCL_ERROR;
goto abnormalResult;
}
@@ -3099,7 +3078,7 @@ DictFilterCmd(
}
TclDecrRefCount(boolObj);
if (satisfied) {
- Tcl_DictObjPut(interp, resultObj, keyObj, valueObj);
+ Tcl_DictObjPut(NULL, resultObj, keyObj, valueObj);
}
break;
case TCL_BREAK:
@@ -3287,18 +3266,17 @@ FinalizeDictUpdate(
for (i=0 ; i<objc ; i+=2) {
objPtr = Tcl_ObjGetVar2(interp, objv[i+1], NULL, 0);
if (objPtr == NULL) {
- Tcl_DictObjRemove(interp, dictPtr, objv[i]);
+ Tcl_DictObjRemove(NULL, 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));
+ Tcl_DictObjPut(NULL, dictPtr, objv[i], Tcl_DuplicateObj(objPtr));
} else {
/* Shouldn't fail */
- Tcl_DictObjPut(interp, dictPtr, objv[i], objPtr);
+ Tcl_DictObjPut(NULL, dictPtr, objv[i], objPtr);
}
}
TclDecrRefCount(argsObj);
diff --git a/generic/tclInt.h b/generic/tclInt.h
index b1a368e..9a2e8dd 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2881,6 +2881,10 @@ MODULE_SCOPE void TclContinuationsCopy(Tcl_Obj *objPtr,
MODULE_SCOPE int TclConvertElement(const char *src, int length,
char *dst, int flags);
MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr);
+MODULE_SCOPE int TclFindDictElement(Tcl_Interp *interp,
+ const char *dict, int dictLength,
+ const char **elementPtr, const char **nextPtr,
+ int *sizePtr, int *literalPtr);
/* TIP #280 - Modified token based evulation, with line information. */
MODULE_SCOPE int TclEvalEx(Tcl_Interp *interp, const char *script,
int numBytes, int flags, int line,
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index 2d00adf..ae3adae 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -111,7 +111,11 @@ static Tcl_HashTable * GetThreadHash(Tcl_ThreadDataKey *keyPtr);
static int SetEndOffsetFromAny(Tcl_Interp *interp,
Tcl_Obj *objPtr);
static void UpdateStringOfEndOffset(Tcl_Obj *objPtr);
-
+static int FindElement(Tcl_Interp *interp, const char *string,
+ int stringLength, const char *typeStr,
+ const char *typeCode, const char **elementPtr,
+ const char **nextPtr, int *sizePtr,
+ int *literalPtr);
/*
* The following is the Tcl object type definition for an object that
* represents a list index in the form, "end-offset". It is used as a
@@ -237,7 +241,7 @@ const Tcl_ObjType tclEndOffsetType = {
* of either braces or quotes to delimit it.
*
* This collection of parsing rules is implemented in the routine
- * TclFindElement().
+ * FindElement().
*
* In order to produce lists that can be parsed by these rules, we need the
* ability to distinguish between characters that are part of a list element
@@ -505,9 +509,70 @@ TclFindElement(
* does not/does require a call to
* TclCopyAndCollapse() by the caller. */
{
- const char *p = list;
+ return FindElement(interp, list, listLength, "list", "LIST", elementPtr,
+ nextPtr, sizePtr, literalPtr);
+}
+
+int
+TclFindDictElement(
+ Tcl_Interp *interp, /* Interpreter to use for error reporting. If
+ * NULL, then no error message is left after
+ * errors. */
+ const char *dict, /* Points to the first byte of a string
+ * containing a Tcl dictionary with zero or
+ * more keys and values (possibly in
+ * braces). */
+ int dictLength, /* Number of bytes in the dict's string. */
+ const char **elementPtr, /* Where to put address of first significant
+ * character in the first element (i.e., key
+ * or value) of dict. */
+ const char **nextPtr, /* Fill in with location of character just
+ * after all white space following end of
+ * element (next arg or end of list). */
+ int *sizePtr, /* If non-zero, fill in with size of
+ * element. */
+ int *literalPtr) /* If non-zero, fill in with non-zero/zero to
+ * indicate that the substring of *sizePtr
+ * bytes starting at **elementPtr is/is not
+ * the literal key or value and therefore
+ * does not/does require a call to
+ * TclCopyAndCollapse() by the caller. */
+{
+ return FindElement(interp, dict, dictLength, "dict", "DICTIONARY",
+ elementPtr, nextPtr, sizePtr, literalPtr);
+}
+
+static int
+FindElement(
+ Tcl_Interp *interp, /* Interpreter to use for error reporting. If
+ * NULL, then no error message is left after
+ * errors. */
+ const char *string, /* Points to the first byte of a string
+ * containing a Tcl list or dictionary with
+ * zero or more elements (possibly in
+ * braces). */
+ int stringLength, /* Number of bytes in the string. */
+ const char *typeStr, /* The name of the type of thing we are
+ * parsing, for error messages. */
+ const char *typeCode, /* The type code for thing we are parsing, for
+ * error messages. */
+ const char **elementPtr, /* Where to put address of first significant
+ * character in first element. */
+ const char **nextPtr, /* Fill in with location of character just
+ * after all white space following end of
+ * argument (next arg or end of list/dict). */
+ int *sizePtr, /* If non-zero, fill in with size of
+ * element. */
+ int *literalPtr) /* If non-zero, fill in with non-zero/zero to
+ * indicate that the substring of *sizePtr
+ * bytes starting at **elementPtr is/is not
+ * the literal list/dict element and therefore
+ * does not/does require a call to
+ * TclCopyAndCollapse() by the caller. */
+{
+ const char *p = string;
const char *elemStart; /* Points to first byte of first element. */
- const char *limit; /* Points just after list's last byte. */
+ const char *limit; /* Points just after list/dict's last byte. */
int openBraces = 0; /* Brace nesting level during parse. */
int inQuotes = 0;
int size = 0; /* lint. */
@@ -517,11 +582,11 @@ TclFindElement(
/*
* Skim off leading white space and check for an opening brace or quote.
- * We treat embedded NULLs in the list as bytes belonging to a list
- * element.
+ * We treat embedded NULLs in the list/dict as bytes belonging to a list
+ * element (or dictionary key or value).
*/
- limit = (list + listLength);
+ limit = (string + stringLength);
while ((p < limit) && (TclIsSpaceProc(*p))) {
p++;
}
@@ -582,9 +647,9 @@ TclFindElement(
p2++;
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "list element in braces followed by \"%.*s\" "
- "instead of space", (int) (p2-p), p));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "JUNK",
+ "%s element in braces followed by \"%.*s\" "
+ "instead of space", typeStr, (int) (p2-p), p));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "JUNK",
NULL);
}
return TCL_ERROR;
@@ -651,9 +716,9 @@ TclFindElement(
p2++;
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "list element in quotes followed by \"%.*s\" "
- "instead of space", (int) (p2-p), p));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "JUNK",
+ "%s element in quotes followed by \"%.*s\" "
+ "instead of space", typeStr, (int) (p2-p), p));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "JUNK",
NULL);
}
return TCL_ERROR;
@@ -664,23 +729,23 @@ TclFindElement(
}
/*
- * End of list: terminate element.
+ * End of list/dict: terminate element.
*/
if (p == limit) {
if (openBraces != 0) {
if (interp != NULL) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "unmatched open brace in list", -1));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "BRACE",
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unmatched open brace in %s", typeStr));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "BRACE",
NULL);
}
return TCL_ERROR;
} else if (inQuotes) {
if (interp != NULL) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "unmatched open quote in list", -1));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "QUOTE",
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "unmatched open quote in %s", typeStr));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "QUOTE",
NULL);
}
return TCL_ERROR;
diff --git a/tests/dict.test b/tests/dict.test
index a583de8..642abd8 100644
--- a/tests/dict.test
+++ b/tests/dict.test
@@ -167,6 +167,51 @@ test dict-4.8 {dict replace command} -returnCodes error -body {
} -result {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-4.11 {dict replace command: canonicality is forced} {
+ dict replace { a b c d }
+} {a b c d}
+test dict-4.12 {dict replace command: canonicality is forced} {
+ dict replace {a b c d a e}
+} {a e c d}
+test dict-4.13 {dict replace command: type check is mandatory} -body {
+ dict replace { a b c d e }
+} -returnCodes error -result {missing value to go with key}
+test dict-4.13a {dict replace command: type check is mandatory} {
+ catch {dict replace { a b c d e }} -> opt
+ dict get $opt -errorcode
+} {TCL VALUE DICTIONARY}
+test dict-4.14 {dict replace command: type check is mandatory} -body {
+ dict replace { a b {}c d }
+} -returnCodes error -result {dict element in braces followed by "c" instead of space}
+test dict-4.14a {dict replace command: type check is mandatory} {
+ catch {dict replace { a b {}c d }} -> opt
+ dict get $opt -errorcode
+} {TCL VALUE DICTIONARY JUNK}
+test dict-4.15 {dict replace command: type check is mandatory} -body {
+ dict replace { a b ""c d }
+} -returnCodes error -result {dict element in quotes followed by "c" instead of space}
+test dict-4.15a {dict replace command: type check is mandatory} {
+ catch {dict replace { a b ""c d }} -> opt
+ dict get $opt -errorcode
+} {TCL VALUE DICTIONARY JUNK}
+test dict-4.16 {dict replace command: type check is mandatory} -body {
+ dict replace " a b \"c d "
+} -returnCodes error -result {unmatched open quote in dict}
+test dict-4.16a {dict replace command: type check is mandatory} {
+ catch {dict replace " a b \"c d "} -> opt
+ dict get $opt -errorcode
+} {TCL VALUE DICTIONARY QUOTE}
+test dict-4.17 {dict replace command: type check is mandatory} -body {
+ dict replace " a b \{c d "
+} -returnCodes error -result {unmatched open brace in dict}
+test dict-4.17a {dict replace command: type check is mandatory} {
+ catch {dict replace " a b \{c d "} -> opt
+ dict get $opt -errorcode
+} {TCL VALUE DICTIONARY BRACE}
+test dict-4.18 {dict replace command: canonicality forcing doesn't leak} {
+ set example { a b c d }
+ list $example [dict replace $example]
+} {{ a b c d } {a b c d}}
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}
@@ -179,6 +224,25 @@ test dict-5.6 {dict remove command} {dict remove {a b} c} {a b}
test dict-5.7 {dict remove command} -returnCodes error -body {
dict remove
} -result {wrong # args: should be "dict remove dictionary ?key ...?"}
+test dict-5.8 {dict remove command: canonicality is forced} {
+ dict remove { a b c d }
+} {a b c d}
+test dict-5.9 {dict remove command: canonicality is forced} {
+ dict remove {a b c d a e}
+} {a e c d}
+test dict-5.10 {dict remove command: canonicality forced by update} {
+ dict remove { a b c d } c
+} {a b}
+test dict-5.11 {dict remove command: type check is mandatory} -body {
+ dict remove { a b c d e }
+} -returnCodes error -result {missing value to go with key}
+test dict-5.12 {dict remove command: type check is mandatory} -body {
+ dict remove { a b {}c d }
+} -returnCodes error -result {dict element in braces followed by "c" instead of space}
+test dict-5.13 {dict remove command: canonicality forcing doesn't leak} {
+ set example { a b c d }
+ list $example [dict remove $example]
+} {{ a b c d } {a b c d}}
test dict-6.1 {dict keys command} {dict keys {a b}} a
test dict-6.2 {dict keys command} {dict keys {c d}} c
@@ -1226,6 +1290,21 @@ test dict-20.19 {dict merge command} {
test dict-20.20 {dict merge command} {
apply {{} {dict merge {a b c d e f} {a x 1 2 3 4} {a - 1 -}}}
} {a - c d e f 1 - 3 4}
+test dict-20.21 {dict merge command: canonicality not forced} {
+ dict merge { a b c d }
+} { a b c d }
+test dict-20.22 {dict merge command: canonicality not forced} {
+ dict merge { a b c d } {}
+} { a b c d }
+test dict-20.23 {dict merge command: canonicality forced by update} {
+ dict merge { a b c d } {a b}
+} {a b c d}
+test dict-20.24 {dict merge command: type check is mandatory} -body {
+ dict merge { a b c d e }
+} -returnCodes error -result {missing value to go with key}
+test dict-20.25 {dict merge command: type check is mandatory} -body {
+ dict merge { a b {}c d }
+} -returnCodes error -result {dict element in braces followed by "c" instead of space}
test dict-21.1 {dict update command} -returnCodes 1 -body {
dict update