int MkView::LoopCmd() {
long first = 0;
long limit = view.GetSize();
long incr = 1;
if (objc >= 5)
first = tcl_ExprLongObj(objv[3]);
if (objc >= 6)
limit = tcl_ExprLongObj(objv[4]);
if (objc >= 7) {
incr = tcl_ExprLongObj(objv[5]);
if (incr == 0)
Fail("increment has to be nonzero");
}
if (_error)
return _error;
Tcl_Obj *vname = objv[2];
Tcl_Obj *cmd = objv[objc - 1];
for (int i = first; i < limit && incr > 0 || i > limit && incr < 0; i += incr)
{
Tcl_Obj *var = Tcl_ObjSetVar2(interp, vname, 0, Tcl_NewIntObj(i),
TCL_LEAVE_ERR_MSG);
if (var == 0)
return Fail();
_error = Mk_EvalObj(interp, cmd);
if (_error) {
if (_error == TCL_CONTINUE)
_error = TCL_OK;
else {
if (_error == TCL_BREAK)
_error = TCL_OK;
else if (_error == TCL_ERROR) {
char msg[100];
sprintf(msg, "\n (\"mk::loop\" body line %d)", Tcl_GetErrorLine(interp));
Tcl_AddObjErrorInfo(interp, msg, - 1);
}
break;
}
}
}
if (_error == TCL_OK)
Tcl_ResetResult(interp);
return _error;
}
static int
Send(
LPDISPATCH pdispInterp, /* Pointer to the remote interp's COM
* object. */
Tcl_Interp *interp, /* The local interpreter. */
int async, /* Flag for the calling style. */
ClientData clientData, /* The RegisteredInterp structure for this
* interp. */
int objc, /* Number of arguments to be sent. */
Tcl_Obj *const objv[]) /* The arguments to be sent. */
{
VARIANT vCmd, vResult;
DISPPARAMS dp;
EXCEPINFO ei;
UINT uiErr = 0;
HRESULT hr = S_OK, ehr = S_OK;
Tcl_Obj *cmd = NULL;
DISPID dispid;
cmd = Tcl_ConcatObj(objc, objv);
/*
* Setup the arguments for the COM method call.
*/
VariantInit(&vCmd);
VariantInit(&vResult);
memset(&dp, 0, sizeof(dp));
memset(&ei, 0, sizeof(ei));
vCmd.vt = VT_BSTR;
vCmd.bstrVal = SysAllocString(Tcl_GetUnicode(cmd));
dp.cArgs = 1;
dp.rgvarg = &vCmd;
/*
* Select the method to use based upon the async flag and call the method.
*/
dispid = async ? TKWINSENDCOM_DISPID_ASYNC : TKWINSENDCOM_DISPID_SEND;
hr = pdispInterp->lpVtbl->Invoke(pdispInterp, dispid,
&IID_NULL, LOCALE_SYSTEM_DEFAULT, DISPATCH_METHOD,
&dp, &vResult, &ei, &uiErr);
/*
* Convert the result into a string and place in the interps result.
*/
ehr = VariantChangeType(&vResult, &vResult, 0, VT_BSTR);
if (SUCCEEDED(ehr)) {
Tcl_SetObjResult(interp, Tcl_NewUnicodeObj(vResult.bstrVal, -1));
}
/*
* Errors are returned as dispatch exceptions. If an error code was
* returned then we decode the exception and setup the Tcl error
* variables.
*/
if (hr == DISP_E_EXCEPTION) {
Tcl_Obj *opError, *opErrorCode, *opErrorInfo;
if (ei.bstrSource != NULL) {
int len;
char *szErrorInfo;
opError = Tcl_NewUnicodeObj(ei.bstrSource, -1);
Tcl_ListObjIndex(interp, opError, 0, &opErrorCode);
Tcl_SetObjErrorCode(interp, opErrorCode);
Tcl_ListObjIndex(interp, opError, 1, &opErrorInfo);
szErrorInfo = Tcl_GetStringFromObj(opErrorInfo, &len);
Tcl_AddObjErrorInfo(interp, szErrorInfo, len);
}
}
/*
* Clean up any COM allocated resources.
*/
SysFreeString(ei.bstrDescription);
SysFreeString(ei.bstrSource);
SysFreeString(ei.bstrHelpFile);
VariantClear(&vCmd);
return (SUCCEEDED(hr) ? TCL_OK : TCL_ERROR);
}
int
Extension::foreachCmd (
ClientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc != 4) {
Tcl_WrongNumArgs(
interp, 1, objv, "varList collectionHandle script");
return TCL_ERROR;
}
Tcl_Obj *pVarList = objv[1];
Tcl_Obj *pBody = objv[3];
Reference *pCollection = referenceHandles.find(interp, objv[2]);
if (pCollection == 0) {
const char *arg = Tcl_GetStringFromObj(objv[2], 0);
Tcl_AppendResult(
interp, "invalid interface pointer handle ", arg, 0);
return TCL_ERROR;
}
// Collections should implement a _NewEnum method which returns an object
// that enumerates the elements.
HRESULT hr;
PositionalArguments arguments;
_variant_t varResult;
hr = pCollection->invoke(
DISPID_NEWENUM,
DISPATCH_METHOD | DISPATCH_PROPERTYGET,
arguments,
&varResult);
if (FAILED(hr) || V_VT(&varResult) != VT_UNKNOWN) {
Tcl_AppendResult(interp, "object is not a collection", NULL);
return TCL_ERROR;
}
IUnknownPtr pUnk(V_UNKNOWN(&varResult));
// Get a specific kind of enumeration.
IEnumVARIANTPtr pEnumVARIANT;
IEnumUnknownPtr pEnumUnknown;
enum EnumKind { ENUM_VARIANT, ENUM_UNKNOWN };
EnumKind enumKind;
hr = pUnk->QueryInterface(
IID_IEnumVARIANT, reinterpret_cast<void **>(&pEnumVARIANT));
if (SUCCEEDED(hr)) {
enumKind = ENUM_VARIANT;
} else {
hr = pUnk->QueryInterface(
IID_IEnumUnknown, reinterpret_cast<void **>(&pEnumUnknown));
if (SUCCEEDED(hr)) {
enumKind = ENUM_UNKNOWN;
}
}
if (FAILED(hr)) {
Tcl_AppendResult(interp,
"Unknown enumerator type: not IEnumVARIANT or IEnumUnknown", NULL);
return TCL_ERROR;
}
int completionCode;
int varc; // number of loop variables
completionCode = Tcl_ListObjLength(interp, pVarList, &varc);
if (completionCode != TCL_OK) {
return TCL_ERROR;
}
if (varc < 1) {
Tcl_AppendResult(interp, "foreach varlist is empty", NULL);
return TCL_ERROR;
}
while (true) {
// If the variable list has been converted to another kind of Tcl
// object, convert it back to a list and refetch the pointer to its
// element array.
Tcl_Obj **varv;
completionCode =
Tcl_ListObjGetElements(interp, pVarList, &varc, &varv);
if (completionCode != TCL_OK) {
return TCL_ERROR;
}
// Assign values to all loop variables.
int v = 0;
for (; v < varc; ++v) {
TclObject value;
ULONG count;
switch (enumKind) {
case ENUM_VARIANT:
{
_variant_t elementVar;
hr = pEnumVARIANT->Next(1, &elementVar, &count);
if (hr == S_OK && count > 0) {
value = TclObject(&elementVar, Type::variant(), interp, 0);
}
}
break;
case ENUM_UNKNOWN:
{
IUnknown *pElement;
hr = pEnumUnknown->Next(1, &pElement, &count);
if (hr == S_OK && count > 0) {
value = referenceHandles.newObj(
interp, Reference::newReference(pElement));
}
}
break;
}
if (FAILED(hr)) {
_com_issue_error(hr);
}
if (hr != S_OK || count == 0) {
break;
}
Tcl_Obj *varValuePtr = Tcl_ObjSetVar2(
interp, varv[v], NULL, value, TCL_LEAVE_ERR_MSG);
if (varValuePtr == NULL) {
return TCL_ERROR;
}
}
if (v == 0) {
completionCode = TCL_OK;
break;
}
if (v < varc) {
TclObject empty;
for (; v < varc; ++v) {
Tcl_Obj *varValuePtr = Tcl_ObjSetVar2(
interp, varv[v], NULL, empty, TCL_LEAVE_ERR_MSG);
if (varValuePtr == NULL) {
return TCL_ERROR;
}
}
}
// Execute the script body.
completionCode =
#if TCL_MINOR_VERSION >= 1
Tcl_EvalObjEx(interp, pBody, 0);
#else
Tcl_EvalObj(interp, pBody);
#endif
if (completionCode == TCL_CONTINUE) {
// do nothing
} else if (completionCode == TCL_BREAK) {
completionCode = TCL_OK;
break;
} else if (completionCode == TCL_ERROR) {
std::ostringstream oss;
oss << "\n (\"foreach\" body line %d)" << interp->errorLine;
Tcl_AddObjErrorInfo(
interp, const_cast<char *>(oss.str().c_str()), -1);
break;
} else if (completionCode != TCL_OK) {
break;
}
}
if (completionCode == TCL_OK) {
Tcl_ResetResult(interp);
}
return completionCode;
}