Attachment "dict-filter.c" to
ticket [2370575fff]
added by
dkf
2019-04-01 09:10:55.
/*
*----------------------------------------------------------------------
*
* DictFilterCmd --
*
* This function implements the "dict filter" Tcl command. See the user
* documentation for details on what it does, and TIP#111 for the formal
* specification.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictFilterCmd(
ClientData dummy,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Interp *iPtr = (Interp *) interp;
static const char *const filters[] = {
"key", "script", "value", NULL
};
enum FilterTypes {
FILTER_KEYS, FILTER_SCRIPT, FILTER_VALUES
};
Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj;
Tcl_Obj **varv, *keyObj = NULL, *valueObj = NULL, *resultObj, *boolObj;
Tcl_DictSearch search;
int index, varc, done, result, satisfied;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "dictionary filterType ?arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[2], filters, "filterType",
0, &index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum FilterTypes) index) {
case FILTER_KEYS:
/*
* Create a dictionary whose keys all match at least one
* of the given patterns.
*/
if (Tcl_DictObjFirst(interp, objv[1], &search,
&keyObj, &valueObj, &done) != TCL_OK) {
return TCL_ERROR;
}
resultObj = Tcl_NewDictObj();
while (!done) {
int idx;
for (idx=3; idx<objc; idx++) {
if (Tcl_StringMatch(TclGetString(keyObj),
TclGetString(objv[idx]))) {
Tcl_DictObjPut(interp, resultObj, keyObj, valueObj);
break;
}
}
Tcl_DictObjNext(&search, &keyObj, &valueObj, &done);
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
case FILTER_VALUES:
/*
* Create a dictionary whose values all match at least one
* of the given patterns.
*/
if (Tcl_DictObjFirst(interp, objv[1], &search,
&keyObj, &valueObj, &done) != TCL_OK) {
return TCL_ERROR;
}
resultObj = Tcl_NewDictObj();
while (!done) {
int idx;
for (idx=3; idx<objc; idx++) {
if (Tcl_StringMatch(TclGetString(valueObj),
TclGetString(objv[idx]))) {
Tcl_DictObjPut(interp, resultObj, keyObj, valueObj);
break;
}
}
Tcl_DictObjNext(&search, &keyObj, &valueObj, &done);
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
case FILTER_SCRIPT:
if (objc != 5) {
Tcl_WrongNumArgs(interp, 1, objv,
"dictionary script {keyVar valueVar} filterScript");
return TCL_ERROR;
}
/*
* Create a dictionary whose key,value pairs all satisfy a script
* (i.e. get a true boolean result from its evaluation). Massive
* copying from the "dict for" implementation has occurred!
*/
if (TclListObjGetElements(interp, objv[3], &varc, &varv) != TCL_OK) {
return TCL_ERROR;
}
if (varc != 2) {
Tcl_SetResult(interp, "must have exactly two variable names",
TCL_STATIC);
return TCL_ERROR;
}
keyVarObj = varv[0];
valueVarObj = varv[1];
scriptObj = objv[4];
/*
* Make sure that these objects (which we need throughout the body of
* the loop) don't vanish. Note that the dictionary internal rep is
* locked internally so that updates, shimmering, etc are not a
* problem.
*/
Tcl_IncrRefCount(keyVarObj);
Tcl_IncrRefCount(valueVarObj);
Tcl_IncrRefCount(scriptObj);
result = Tcl_DictObjFirst(interp, objv[1],
&search, &keyObj, &valueObj, &done);
if (result != TCL_OK) {
TclDecrRefCount(keyVarObj);
TclDecrRefCount(valueVarObj);
TclDecrRefCount(scriptObj);
return TCL_ERROR;
}
resultObj = Tcl_NewDictObj();
while (!done) {
/*
* Stop the value from getting hit in any way by any traces on the
* key variable.
*/
Tcl_IncrRefCount(keyObj);
Tcl_IncrRefCount(valueObj);
if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj,
TCL_LEAVE_ERR_MSG) == NULL) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "couldn't set key variable: \"",
TclGetString(keyVarObj), "\"", NULL);
result = TCL_ERROR;
goto abnormalResult;
}
if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj,
TCL_LEAVE_ERR_MSG) == NULL) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "couldn't set value variable: \"",
TclGetString(valueVarObj), "\"", NULL);
goto abnormalResult;
}
/*
* TIP #280. Make invoking context available to loop body.
*/
result = TclEvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 4);
switch (result) {
case TCL_OK:
boolObj = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(boolObj);
Tcl_ResetResult(interp);
if (Tcl_GetBooleanFromObj(interp, boolObj,
&satisfied) != TCL_OK) {
TclDecrRefCount(boolObj);
result = TCL_ERROR;
goto abnormalResult;
}
TclDecrRefCount(boolObj);
if (satisfied) {
Tcl_DictObjPut(interp, resultObj, keyObj, valueObj);
}
break;
case TCL_BREAK:
/*
* Force loop termination by calling Tcl_DictObjDone; this
* makes the next Tcl_DictObjNext say there is nothing more to
* do.
*/
Tcl_ResetResult(interp);
Tcl_DictObjDone(&search);
case TCL_CONTINUE:
result = TCL_OK;
break;
case TCL_ERROR:
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (\"dict filter\" script line %d)",
interp->errorLine));
default:
goto abnormalResult;
}
TclDecrRefCount(keyObj);
TclDecrRefCount(valueObj);
Tcl_DictObjNext(&search, &keyObj, &valueObj, &done);
}
/*
* Stop holding a reference to these objects.
*/
TclDecrRefCount(keyVarObj);
TclDecrRefCount(valueVarObj);
TclDecrRefCount(scriptObj);
Tcl_DictObjDone(&search);
if (result == TCL_OK) {
Tcl_SetObjResult(interp, resultObj);
} else {
TclDecrRefCount(resultObj);
}
return result;
abnormalResult:
Tcl_DictObjDone(&search);
TclDecrRefCount(keyObj);
TclDecrRefCount(valueObj);
TclDecrRefCount(keyVarObj);
TclDecrRefCount(valueVarObj);
TclDecrRefCount(scriptObj);
TclDecrRefCount(resultObj);
return result;
}
Tcl_Panic("unexpected fallthrough");
/* Control never reaches this point. */
return TCL_ERROR;
}
