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; }