summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog5
-rw-r--r--generic/tclDictObj.c439
2 files changed, 384 insertions, 60 deletions
diff --git a/ChangeLog b/ChangeLog
index c610f41..5d793f7 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2004-10-08 Donal K. Fellows <donal.k.fellows@man.ac.uk>
+
+ * generic/tclDictObj.c (DictUpdateCmd,DictWithCmd): Core of
+ implementation of TIP#212; docs and tests still to do...
+
2004-10-07 Don Porter <dgp@users.sourceforge.net>
* generic/tclTest.c (TestsetobjerrorcodeCmd): Simplified.
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index 7b5007c..9fadc83 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.21 2004/10/06 05:52:21 dgp Exp $
+ * RCS: @(#) $Id: tclDictObj.c,v 1.22 2004/10/08 15:05:05 dkf Exp $
*/
#include "tclInt.h"
@@ -85,6 +85,10 @@ static int DictUnsetCmd _ANSI_ARGS_((Tcl_Interp *interp,
int objc, Tcl_Obj *CONST *objv));
static int DictValuesCmd _ANSI_ARGS_((Tcl_Interp *interp,
int objc, Tcl_Obj *CONST *objv));
+static int DictUpdateCmd _ANSI_ARGS_((Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST *objv));
+static int DictWithCmd _ANSI_ARGS_((Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST *objv));
static void DupDictInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr));
static void FreeDictInternalRep _ANSI_ARGS_((Tcl_Obj *dictPtr));
@@ -262,7 +266,7 @@ DeleteDict(dict)
for (hPtr=Tcl_FirstHashEntry(&dict->table,&search); hPtr!=NULL;
hPtr=Tcl_NextHashEntry(&search)) {
valuePtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr);
- Tcl_DecrRefCount(valuePtr);
+ TclDecrRefCount(valuePtr);
}
Tcl_DeleteHashTable(&dict->table);
ckfree((char *) dict);
@@ -447,7 +451,7 @@ SetDictFromAny(interp, objPtr)
hPtr = Tcl_CreateHashEntry(&dict->table, (char *)objv[i], &isNew);
if (!isNew) {
Tcl_Obj *discardedValue = (Tcl_Obj *) Tcl_GetHashValue(hPtr);
- Tcl_DecrRefCount(discardedValue);
+ TclDecrRefCount(discardedValue);
}
Tcl_SetHashValue(hPtr, (ClientData) objv[i+1]);
Tcl_IncrRefCount(objv[i+1]); /* since hash now holds ref to it */
@@ -511,7 +515,7 @@ SetDictFromAny(interp, objPtr)
result = TclFindElement(interp, p, lenRemain,
&elemStart, &nextElem, &elemSize, &hasBrace);
if (result != TCL_OK) {
- Tcl_DecrRefCount(keyPtr);
+ TclDecrRefCount(keyPtr);
goto errorExit;
}
if (elemStart >= limit) {
@@ -541,8 +545,8 @@ SetDictFromAny(interp, objPtr)
hPtr = Tcl_CreateHashEntry(&dict->table, (char *)keyPtr, &isNew);
if (!isNew) {
Tcl_Obj *discardedValue = (Tcl_Obj *) Tcl_GetHashValue(hPtr);
- Tcl_DecrRefCount(keyPtr);
- Tcl_DecrRefCount(discardedValue);
+ TclDecrRefCount(keyPtr);
+ TclDecrRefCount(discardedValue);
}
Tcl_SetHashValue(hPtr, (ClientData) valuePtr);
Tcl_IncrRefCount(valuePtr); /* since hash now holds ref to it */
@@ -568,13 +572,13 @@ SetDictFromAny(interp, objPtr)
Tcl_SetObjResult(interp,
Tcl_NewStringObj("missing value to go with key", -1));
}
- Tcl_DecrRefCount(keyPtr);
+ TclDecrRefCount(keyPtr);
result = TCL_ERROR;
errorExit:
for (hPtr=Tcl_FirstHashEntry(&dict->table,&search);
hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search)) {
valuePtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr);
- Tcl_DecrRefCount(valuePtr);
+ TclDecrRefCount(valuePtr);
}
Tcl_DeleteHashTable(&dict->table);
ckfree((char *) dict);
@@ -671,7 +675,7 @@ TraceDictPath(interp, dictPtr, keyc, keyv, flags)
newDict = (Dict *) tmpObj->internalRep.otherValuePtr;
if (flags & DICT_PATH_UPDATE) {
if (Tcl_IsShared(tmpObj)) {
- Tcl_DecrRefCount(tmpObj);
+ TclDecrRefCount(tmpObj);
tmpObj = Tcl_DuplicateObj(tmpObj);
Tcl_IncrRefCount(tmpObj);
Tcl_SetHashValue(hPtr, (ClientData) tmpObj);
@@ -772,7 +776,7 @@ Tcl_DictObjPut(interp, dictPtr, keyPtr, valuePtr)
Tcl_IncrRefCount(valuePtr);
if (!isNew) {
Tcl_Obj *oldValuePtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr);
- Tcl_DecrRefCount(oldValuePtr);
+ TclDecrRefCount(oldValuePtr);
}
Tcl_SetHashValue(hPtr, valuePtr);
dict->epoch++;
@@ -870,7 +874,7 @@ Tcl_DictObjRemove(interp, dictPtr, keyPtr)
if (hPtr != NULL) {
Tcl_Obj *valuePtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr);
- Tcl_DecrRefCount(valuePtr);
+ TclDecrRefCount(valuePtr);
Tcl_DeleteHashEntry(hPtr);
dict->epoch++;
}
@@ -1141,7 +1145,7 @@ Tcl_DictObjPutKeyList(interp, dictPtr, keyc, keyv, valuePtr)
Tcl_IncrRefCount(valuePtr);
if (!isNew) {
Tcl_Obj *oldValuePtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr);
- Tcl_DecrRefCount(oldValuePtr);
+ TclDecrRefCount(oldValuePtr);
}
Tcl_SetHashValue(hPtr, valuePtr);
InvalidateDictChain(dictPtr);
@@ -1196,7 +1200,7 @@ Tcl_DictObjRemoveKeyList(interp, dictPtr, keyc, keyv)
hPtr = Tcl_FindHashEntry(&dict->table, (char *)keyv[keyc-1]);
if (hPtr != NULL) {
Tcl_Obj *oldValuePtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr);
- Tcl_DecrRefCount(oldValuePtr);
+ TclDecrRefCount(oldValuePtr);
Tcl_DeleteHashEntry(hPtr);
}
InvalidateDictChain(dictPtr);
@@ -1421,6 +1425,7 @@ DictGetCmd(interp, objc, objv)
* going through a chain of searches.) Note that this loop always
* executes at least once.
*/
+
dictPtr = TraceDictPath(interp, objv[2], objc-4, objv+3, DICT_PATH_READ);
if (dictPtr == NULL) {
return TCL_ERROR;
@@ -1481,7 +1486,7 @@ DictReplaceCmd(interp, objc, objv)
result = Tcl_DictObjPut(interp, dictPtr, objv[i], objv[i+1]);
if (result != TCL_OK) {
if (allocatedDict) {
- Tcl_DecrRefCount(dictPtr);
+ TclDecrRefCount(dictPtr);
}
return TCL_ERROR;
}
@@ -1532,7 +1537,7 @@ DictRemoveCmd(interp, objc, objv)
result = Tcl_DictObjRemove(interp, dictPtr, objv[i]);
if (result != TCL_OK) {
if (allocatedDict) {
- Tcl_DecrRefCount(dictPtr);
+ TclDecrRefCount(dictPtr);
}
return TCL_ERROR;
}
@@ -1604,7 +1609,7 @@ DictMergeCmd(interp, objc, objv)
if (Tcl_DictObjFirst(interp, objv[i], &search, &keyObj, &valueObj,
&done) != TCL_OK) {
if (allocatedDict) {
- Tcl_DecrRefCount(targetObj);
+ TclDecrRefCount(targetObj);
}
return TCL_ERROR;
}
@@ -1613,7 +1618,7 @@ DictMergeCmd(interp, objc, objv)
keyObj, valueObj) != TCL_OK) {
Tcl_DictObjDone(&search);
if (allocatedDict) {
- Tcl_DecrRefCount(targetObj);
+ TclDecrRefCount(targetObj);
}
return TCL_ERROR;
}
@@ -1941,7 +1946,7 @@ DictIncrCmd(interp, objc, objv)
if (Tcl_DictObjGet(interp, dictPtr, objv[3], &valuePtr) != TCL_OK) {
if (allocatedDict) {
- Tcl_DecrRefCount(dictPtr);
+ TclDecrRefCount(dictPtr);
}
return TCL_ERROR;
}
@@ -1999,7 +2004,7 @@ DictIncrCmd(interp, objc, objv)
result = Tcl_GetWideIntFromObj(interp, valuePtr, &wValue);
if (result != TCL_OK) {
if (allocatedDict) {
- Tcl_DecrRefCount(dictPtr);
+ TclDecrRefCount(dictPtr);
}
return result;
}
@@ -2039,9 +2044,9 @@ DictIncrCmd(interp, objc, objv)
* from above to be a valid dictionary.
*/
if (allocatedDict) {
- Tcl_DecrRefCount(dictPtr);
+ TclDecrRefCount(dictPtr);
}
- Tcl_DecrRefCount(valuePtr);
+ TclDecrRefCount(valuePtr);
return TCL_ERROR;
}
}
@@ -2049,7 +2054,7 @@ DictIncrCmd(interp, objc, objv)
Tcl_IncrRefCount(dictPtr);
resultPtr = Tcl_ObjSetVar2(interp, objv[2], NULL, dictPtr,
TCL_LEAVE_ERR_MSG);
- Tcl_DecrRefCount(dictPtr);
+ TclDecrRefCount(dictPtr);
if (resultPtr == NULL) {
return TCL_ERROR;
}
@@ -2100,7 +2105,7 @@ DictLappendCmd(interp, objc, objv)
if (Tcl_DictObjGet(interp, dictPtr, objv[3], &valuePtr) != TCL_OK) {
if (allocatedDict) {
- Tcl_DecrRefCount(dictPtr);
+ TclDecrRefCount(dictPtr);
}
return TCL_ERROR;
}
@@ -2118,10 +2123,10 @@ DictLappendCmd(interp, objc, objv)
if (Tcl_ListObjAppendElement(interp, valuePtr,
objv[i]) != TCL_OK) {
if (allocatedValue) {
- Tcl_DecrRefCount(valuePtr);
+ TclDecrRefCount(valuePtr);
}
if (allocatedDict) {
- Tcl_DecrRefCount(dictPtr);
+ TclDecrRefCount(dictPtr);
}
return TCL_ERROR;
}
@@ -2137,7 +2142,7 @@ DictLappendCmd(interp, objc, objv)
Tcl_IncrRefCount(dictPtr);
resultPtr = Tcl_ObjSetVar2(interp, objv[2], NULL, dictPtr,
TCL_LEAVE_ERR_MSG);
- Tcl_DecrRefCount(dictPtr);
+ TclDecrRefCount(dictPtr);
if (resultPtr == NULL) {
return TCL_ERROR;
}
@@ -2188,7 +2193,7 @@ DictAppendCmd(interp, objc, objv)
if (Tcl_DictObjGet(interp, dictPtr, objv[3], &valuePtr) != TCL_OK) {
if (allocatedDict) {
- Tcl_DecrRefCount(dictPtr);
+ TclDecrRefCount(dictPtr);
}
return TCL_ERROR;
}
@@ -2210,7 +2215,7 @@ DictAppendCmd(interp, objc, objv)
Tcl_IncrRefCount(dictPtr);
resultPtr = Tcl_ObjSetVar2(interp, objv[2], NULL, dictPtr,
TCL_LEAVE_ERR_MSG);
- Tcl_DecrRefCount(dictPtr);
+ TclDecrRefCount(dictPtr);
if (resultPtr == NULL) {
return TCL_ERROR;
}
@@ -2295,11 +2300,11 @@ DictForCmd(interp, objc, objv)
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "couldn't set key variable: \"",
TclGetString(keyVarObj), "\"", (char *) NULL);
- Tcl_DecrRefCount(valueObj);
+ TclDecrRefCount(valueObj);
result = TCL_ERROR;
goto doneFor;
}
- Tcl_DecrRefCount(valueObj);
+ TclDecrRefCount(valueObj);
if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, 0) == NULL) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "couldn't set value variable: \"",
@@ -2331,10 +2336,10 @@ DictForCmd(interp, objc, objv)
/*
* Stop holding a reference to these objects.
*/
- Tcl_DecrRefCount(keyVarObj);
- Tcl_DecrRefCount(valueVarObj);
- Tcl_DecrRefCount(dictObj);
- Tcl_DecrRefCount(scriptObj);
+ TclDecrRefCount(keyVarObj);
+ TclDecrRefCount(valueVarObj);
+ TclDecrRefCount(dictObj);
+ TclDecrRefCount(scriptObj);
Tcl_DictObjDone(&search);
if (result == TCL_OK) {
@@ -2388,7 +2393,7 @@ DictSetCmd(interp, objc, objv)
objv[objc-1]);
if (result != TCL_OK) {
if (allocatedDict) {
- Tcl_DecrRefCount(dictPtr);
+ TclDecrRefCount(dictPtr);
}
return TCL_ERROR;
}
@@ -2396,7 +2401,7 @@ DictSetCmd(interp, objc, objv)
Tcl_IncrRefCount(dictPtr);
resultPtr = Tcl_ObjSetVar2(interp, objv[2], NULL, dictPtr,
TCL_LEAVE_ERR_MSG);
- Tcl_DecrRefCount(dictPtr);
+ TclDecrRefCount(dictPtr);
if (resultPtr == NULL) {
return TCL_ERROR;
}
@@ -2448,7 +2453,7 @@ DictUnsetCmd(interp, objc, objv)
result = Tcl_DictObjRemoveKeyList(interp, dictPtr, objc-3, objv+3);
if (result != TCL_OK) {
if (allocatedDict) {
- Tcl_DecrRefCount(dictPtr);
+ TclDecrRefCount(dictPtr);
}
return TCL_ERROR;
}
@@ -2456,7 +2461,7 @@ DictUnsetCmd(interp, objc, objv)
Tcl_IncrRefCount(dictPtr);
resultPtr = Tcl_ObjSetVar2(interp, objv[2], NULL, dictPtr,
TCL_LEAVE_ERR_MSG);
- Tcl_DecrRefCount(dictPtr);
+ TclDecrRefCount(dictPtr);
if (resultPtr == NULL) {
return TCL_ERROR;
}
@@ -2602,10 +2607,10 @@ DictFilterCmd(interp, objc, objv)
result = Tcl_DictObjFirst(interp, dictObj,
&search, &keyObj, &valueObj, &done);
if (result != TCL_OK) {
- Tcl_DecrRefCount(keyVarObj);
- Tcl_DecrRefCount(valueVarObj);
- Tcl_DecrRefCount(dictObj);
- Tcl_DecrRefCount(scriptObj);
+ TclDecrRefCount(keyVarObj);
+ TclDecrRefCount(valueVarObj);
+ TclDecrRefCount(dictObj);
+ TclDecrRefCount(scriptObj);
return TCL_ERROR;
}
@@ -2642,11 +2647,11 @@ DictFilterCmd(interp, objc, objv)
Tcl_ResetResult(interp);
if (Tcl_GetBooleanFromObj(interp, boolObj,
&satisfied) != TCL_OK) {
- Tcl_DecrRefCount(boolObj);
+ TclDecrRefCount(boolObj);
result = TCL_ERROR;
goto abnormalResult;
}
- Tcl_DecrRefCount(boolObj);
+ TclDecrRefCount(boolObj);
if (satisfied) {
Tcl_DictObjPut(interp, resultObj, keyObj, valueObj);
}
@@ -2670,8 +2675,8 @@ DictFilterCmd(interp, objc, objv)
goto abnormalResult;
}
- Tcl_DecrRefCount(keyObj);
- Tcl_DecrRefCount(valueObj);
+ TclDecrRefCount(keyObj);
+ TclDecrRefCount(valueObj);
Tcl_DictObjNext(&search, &keyObj, &valueObj, &done);
}
@@ -2679,16 +2684,16 @@ DictFilterCmd(interp, objc, objv)
/*
* Stop holding a reference to these objects.
*/
- Tcl_DecrRefCount(keyVarObj);
- Tcl_DecrRefCount(valueVarObj);
- Tcl_DecrRefCount(dictObj);
- Tcl_DecrRefCount(scriptObj);
+ TclDecrRefCount(keyVarObj);
+ TclDecrRefCount(valueVarObj);
+ TclDecrRefCount(dictObj);
+ TclDecrRefCount(scriptObj);
Tcl_DictObjDone(&search);
if (result == TCL_OK) {
Tcl_SetObjResult(interp, resultObj);
} else {
- Tcl_DecrRefCount(resultObj);
+ TclDecrRefCount(resultObj);
}
return result;
}
@@ -2698,13 +2703,323 @@ DictFilterCmd(interp, objc, objv)
abnormalResult:
Tcl_DictObjDone(&search);
- Tcl_DecrRefCount(keyObj);
- Tcl_DecrRefCount(valueObj);
- Tcl_DecrRefCount(keyVarObj);
- Tcl_DecrRefCount(valueVarObj);
- Tcl_DecrRefCount(dictObj);
- Tcl_DecrRefCount(scriptObj);
- Tcl_DecrRefCount(resultObj);
+ TclDecrRefCount(keyObj);
+ TclDecrRefCount(valueObj);
+ TclDecrRefCount(keyVarObj);
+ TclDecrRefCount(valueVarObj);
+ TclDecrRefCount(dictObj);
+ TclDecrRefCount(scriptObj);
+ TclDecrRefCount(resultObj);
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DictUpdateCmd --
+ *
+ * This function implements the "dict update" Tcl command.
+ * See the user documentation for details on what it does, and
+ * TIP#323 for the formal specification.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+DictUpdateCmd(interp, objc, objv)
+ Tcl_Interp *interp;
+ int objc;
+ Tcl_Obj *CONST *objv;
+{
+ Tcl_Obj *dictPtr, *objPtr;
+ int i, result, dummy, allocdict = 0;
+ Tcl_SavedResult sr;
+
+ if (objc < 6 || objc & 1) {
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "varName key varName ?key varName ...? script");
+ return TCL_ERROR;
+ }
+
+ dictPtr = Tcl_ObjGetVar2(interp, objv[2], NULL, TCL_LEAVE_ERR_MSG);
+ if (dictPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (Tcl_DictObjSize(interp, dictPtr, &dummy) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ Tcl_IncrRefCount(dictPtr);
+ for (i=3 ; i+2<objc ; i+=2) {
+ if (Tcl_DictObjGet(interp, dictPtr, objv[i], &objPtr) != TCL_OK) {
+ TclDecrRefCount(dictPtr);
+ return TCL_ERROR;
+ }
+ if (objPtr == NULL) {
+ /* ??? */
+ Tcl_UnsetVar(interp, Tcl_GetString(objv[i+1]), 0);
+ } else if (Tcl_ObjSetVar2(interp, objv[i+1], NULL, objPtr,
+ TCL_LEAVE_ERR_MSG) == NULL) {
+ TclDecrRefCount(dictPtr);
+ return TCL_ERROR;
+ }
+ }
+ TclDecrRefCount(dictPtr);
+
+ /*
+ * Execute the body.
+ */
+
+ result = Tcl_EvalObj(interp, objv[objc-1]);
+ if (result == TCL_ERROR) {
+ Tcl_AddErrorInfo(interp, "\n (body of \"dict update\")");
+ }
+
+ /*
+ * If the dictionary variable doesn't exist, drop everything
+ * silently.
+ */
+
+ dictPtr = Tcl_ObjGetVar2(interp, objv[2], NULL, 0);
+ if (dictPtr == NULL) {
+ return TCL_OK;
+ }
+
+ /*
+ * Double-check that it is still a dictionary.
+ */
+
+ Tcl_SaveResult(interp, &sr);
+ if (Tcl_DictObjSize(interp, dictPtr, &dummy) != TCL_OK) {
+ Tcl_DiscardResult(&sr);
+ return TCL_ERROR;
+ }
+
+ if (Tcl_IsShared(dictPtr)) {
+ dictPtr = Tcl_DuplicateObj(dictPtr);
+ allocdict = 1;
+ }
+
+ /*
+ * Write back the values from the variables, treating failure to
+ * read as an instruction to remove the key.
+ */
+
+ for (i=3 ; i+2<objc ; i+=2) {
+ objPtr = Tcl_ObjGetVar2(interp, objv[i+1], NULL, 0);
+ if (objPtr == NULL) {
+ Tcl_DictObjRemove(interp, dictPtr, objv[i]);
+ } else {
+ /* Shouldn't fail */
+ Tcl_DictObjPut(interp, dictPtr, objv[i], objPtr);
+ }
+ }
+
+ /*
+ * Write the dictionary back to its variable.
+ */
+
+ if (Tcl_ObjSetVar2(interp, objv[2], NULL, dictPtr,
+ TCL_LEAVE_ERR_MSG) != TCL_OK) {
+ Tcl_DiscardResult(&sr);
+ if (allocdict) {
+ TclDecrRefCount(dictPtr);
+ }
+ return TCL_ERROR;
+ }
+
+ Tcl_RestoreResult(interp, &sr);
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DictWithCmd --
+ *
+ * This function implements the "dict with" Tcl command.
+ * See the user documentation for details on what it does, and
+ * TIP#323 for the formal specification.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+DictWithCmd(interp, objc, objv)
+ Tcl_Interp *interp;
+ int objc;
+ Tcl_Obj *CONST *objv;
+{
+ Tcl_Obj *dictPtr, *keysPtr, *keyPtr, *valPtr, **keyv, *leafPtr;
+ Tcl_DictSearch s;
+ Tcl_SavedResult sr;
+ int done, result, keyc, i, allocdict=0;
+
+ if (objc < 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "dictVar ?key ...? script");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Get the dictionary to open out.
+ */
+
+ dictPtr = Tcl_ObjGetVar2(interp, objv[2], NULL, TCL_LEAVE_ERR_MSG);
+ if (dictPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (objc > 4) {
+ dictPtr = TraceDictPath(interp, dictPtr, objc-4, objv+3,
+ DICT_PATH_READ);
+ if (dictPtr == NULL) {
+ return TCL_ERROR;
+ }
+ }
+
+ /*
+ * Go over the list of keys and write each corresponding value to
+ * a variable in the current context with the same name. Also
+ * keep a copy of the keys so we can write back properly later on
+ * even if the dictionary has been structurally modified.
+ */
+
+ if (Tcl_DictObjFirst(interp, dictPtr, &s, &keyPtr, &valPtr,
+ &done) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ Tcl_IncrRefCount(dictPtr);
+ TclNewObj(keysPtr);
+ Tcl_IncrRefCount(keysPtr);
+
+ for (; !done ; Tcl_DictObjNext(&s, &keyPtr, &valPtr, &done)) {
+ Tcl_ListObjAppendElement(NULL, keysPtr, keyPtr);
+ if (Tcl_ObjSetVar2(interp, keyPtr, NULL, valPtr,
+ TCL_LEAVE_ERR_MSG) == NULL) {
+ TclDecrRefCount(dictPtr);
+ TclDecrRefCount(keysPtr);
+ Tcl_DictObjDone(&s);
+ return TCL_ERROR;
+ }
+ }
+ TclDecrRefCount(dictPtr);
+
+ /*
+ * Execute the body.
+ */
+
+ result = Tcl_EvalObjEx(interp, objv[objc-1], 0);
+ if (result == TCL_ERROR) {
+ Tcl_AddErrorInfo(interp, "\n (body of \"dict with\")");
+ }
+
+ /*
+ * If the dictionary variable doesn't exist, drop everything
+ * silently.
+ */
+
+ dictPtr = Tcl_ObjGetVar2(interp, objv[2], NULL, 0);
+ if (dictPtr == NULL) {
+ TclDecrRefCount(keysPtr);
+ return result;
+ }
+
+ /*
+ * Double-check that it is still a dictionary.
+ */
+
+ Tcl_SaveResult(interp, &sr);
+ if (Tcl_DictObjSize(interp, dictPtr, &i) != TCL_OK) {
+ TclDecrRefCount(keysPtr);
+ Tcl_DiscardResult(&sr);
+ return TCL_ERROR;
+ }
+
+ if (Tcl_IsShared(dictPtr)) {
+ dictPtr = Tcl_DuplicateObj(dictPtr);
+ allocdict = 1;
+ }
+
+ if (objc > 4) {
+ /*
+ * Want to get to the dictionary which we will update; need to
+ * do prepare-for-update de-sharing along the path *but* avoid
+ * generating an error on a non-existant path (we'll treat
+ * that the same as a non-existant variable. Luckily, the
+ * de-sharing operation isn't deeply damaging if we don't go
+ * on to update; it's just less than perfectly efficient (but
+ * no memory should be leaked).
+ */
+ leafPtr = TraceDictPath(interp, dictPtr, objc-4, objv+3,
+ DICT_PATH_EXISTS | DICT_PATH_UPDATE);
+ if (leafPtr == NULL) {
+ TclDecrRefCount(keysPtr);
+ if (allocdict) {
+ TclDecrRefCount(dictPtr);
+ }
+ Tcl_DiscardResult(&sr);
+ return TCL_ERROR;
+ }
+ if (leafPtr == DICT_PATH_NON_EXISTENT) {
+ TclDecrRefCount(keysPtr);
+ if (allocdict) {
+ TclDecrRefCount(dictPtr);
+ }
+ Tcl_RestoreResult(interp, &sr);
+ return TCL_OK;
+ }
+ } else {
+ leafPtr = dictPtr;
+ }
+
+ /*
+ * Now process our updates on the leaf dictionary.
+ */
+
+ Tcl_ListObjGetElements(NULL, keysPtr, &keyc, &keyv);
+ for (i=0 ; i<keyc ; i++) {
+ valPtr = Tcl_ObjGetVar2(interp, keyv[i], NULL, 0);
+ if (valPtr == NULL) {
+ Tcl_DictObjRemove(NULL, leafPtr, keyv[i]);
+ } else {
+ Tcl_DictObjPut(NULL, leafPtr, keyv[i], valPtr);
+ }
+ }
+ TclDecrRefCount(keysPtr);
+
+ /*
+ * Ensure that none of the dictionaries in the chain still have a
+ * string rep.
+ */
+
+ if (objc > 4) {
+ InvalidateDictChain(leafPtr);
+ }
+
+ /*
+ * Write back the outermost dictionary to the variable.
+ */
+
+ if (Tcl_ObjSetVar2(interp, objv[2], NULL, dictPtr,
+ TCL_LEAVE_ERR_MSG) == NULL) {
+ if (allocdict) {
+ TclDecrRefCount(dictPtr);
+ }
+ Tcl_DiscardResult(&sr);
+ return TCL_ERROR;
+ }
+ Tcl_RestoreResult(interp, &sr);
return result;
}
@@ -2736,12 +3051,14 @@ Tcl_DictObjCmd(/*ignored*/ clientData, interp, objc, objv)
static CONST char *subcommands[] = {
"append", "create", "exists", "filter", "for",
"get", "incr", "info", "keys", "lappend", "merge",
- "remove", "replace", "set", "size", "unset", "values", NULL
+ "remove", "replace", "set", "size", "unset",
+ "update", "values", "with", NULL
};
enum DictSubcommands {
DICT_APPEND, DICT_CREATE, DICT_EXISTS, DICT_FILTER, DICT_FOR,
DICT_GET, DICT_INCR, DICT_INFO, DICT_KEYS, DICT_LAPPEND, DICT_MERGE,
- DICT_REMOVE, DICT_REPLACE, DICT_SET, DICT_SIZE, DICT_UNSET, DICT_VALUES
+ DICT_REMOVE, DICT_REPLACE, DICT_SET, DICT_SIZE, DICT_UNSET,
+ DICT_UPDATE, DICT_VALUES, DICT_WITH
};
int index;
@@ -2770,7 +3087,9 @@ Tcl_DictObjCmd(/*ignored*/ clientData, interp, objc, objv)
case DICT_SET: return DictSetCmd(interp, objc, objv);
case DICT_SIZE: return DictSizeCmd(interp, objc, objv);
case DICT_UNSET: return DictUnsetCmd(interp, objc, objv);
+ case DICT_UPDATE: return DictUpdateCmd(interp, objc, objv);
case DICT_VALUES: return DictValuesCmd(interp, objc, objv);
+ case DICT_WITH: return DictWithCmd(interp, objc, objv);
}
Tcl_Panic("unexpected fallthrough!");
/*