void
TkWinSend_SetExcepInfo(
Tcl_Interp *interp,
EXCEPINFO *pExcepInfo)
{
Tcl_Obj *opError, *opErrorInfo, *opErrorCode;
ICreateErrorInfo *pCEI;
IErrorInfo *pEI, **ppEI = &pEI;
HRESULT hr;
if (!pExcepInfo) {
return;
}
opError = Tcl_GetObjResult(interp);
opErrorInfo = Tcl_GetVar2Ex(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY);
opErrorCode = Tcl_GetVar2Ex(interp, "errorCode", NULL, TCL_GLOBAL_ONLY);
/*
* Pack the trace onto the end of the Tcl exception descriptor.
*/
opErrorCode = Tcl_DuplicateObj(opErrorCode);
Tcl_IncrRefCount(opErrorCode);
Tcl_ListObjAppendElement(interp, opErrorCode, opErrorInfo);
/* TODO: Handle failure to append */
pExcepInfo->bstrDescription = SysAllocString(Tcl_GetUnicode(opError));
pExcepInfo->bstrSource = SysAllocString(Tcl_GetUnicode(opErrorCode));
Tcl_DecrRefCount(opErrorCode);
pExcepInfo->scode = E_FAIL;
hr = CreateErrorInfo(&pCEI);
if (!SUCCEEDED(hr)) {
return;
}
hr = pCEI->lpVtbl->SetGUID(pCEI, &IID_IDispatch);
hr = pCEI->lpVtbl->SetDescription(pCEI, pExcepInfo->bstrDescription);
hr = pCEI->lpVtbl->SetSource(pCEI, pExcepInfo->bstrSource);
hr = pCEI->lpVtbl->QueryInterface(pCEI, &IID_IErrorInfo, (void **) ppEI);
if (SUCCEEDED(hr)) {
SetErrorInfo(0, pEI);
pEI->lpVtbl->Release(pEI);
}
pCEI->lpVtbl->Release(pCEI);
}
void
SetExcepInfo(
Tcl_Interp* interp,
EXCEPINFO *pExcepInfo)
{
if (pExcepInfo) {
Tcl_Obj *opError, *opErrorInfo, *opErrorCode;
ICreateErrorInfo *pCEI;
IErrorInfo *pEI, **ppEI = &pEI;
HRESULT hr;
opError = Tcl_GetObjResult(interp);
opErrorInfo = Tcl_GetVar2Ex(interp, "errorInfo",NULL, TCL_GLOBAL_ONLY);
opErrorCode = Tcl_GetVar2Ex(interp, "errorCode",NULL, TCL_GLOBAL_ONLY);
if (Tcl_IsShared(opErrorCode)) {
Tcl_Obj *ec = Tcl_DuplicateObj(opErrorCode);
Tcl_IncrRefCount(ec);
Tcl_DecrRefCount(opErrorCode);
opErrorCode = ec;
}
Tcl_ListObjAppendElement(interp, opErrorCode, opErrorInfo);
pExcepInfo->bstrDescription = SysAllocString(Tcl_GetUnicode(opError));
pExcepInfo->bstrSource = SysAllocString(Tcl_GetUnicode(opErrorCode));
pExcepInfo->scode = E_FAIL;
hr = CreateErrorInfo(&pCEI);
if (SUCCEEDED(hr)) {
hr = pCEI->lpVtbl->SetGUID(pCEI, &IID_IDispatch);
hr = pCEI->lpVtbl->SetDescription(pCEI,
pExcepInfo->bstrDescription);
hr = pCEI->lpVtbl->SetSource(pCEI, pExcepInfo->bstrSource);
hr = pCEI->lpVtbl->QueryInterface(pCEI, &IID_IErrorInfo,
(void**) ppEI);
if (SUCCEEDED(hr)) {
SetErrorInfo(0, pEI);
pEI->lpVtbl->Release(pEI);
}
pCEI->lpVtbl->Release(pCEI);
}
}
}
static HRESULT
Send(
TkWinSendCom *obj,
VARIANT vCmd,
VARIANT *pvResult,
EXCEPINFO *pExcepInfo,
UINT *puArgErr)
{
HRESULT hr = S_OK;
int result = TCL_OK;
VARIANT v;
register Tcl_Interp *interp = obj->interp;
Tcl_Obj *scriptPtr;
if (interp == NULL) {
return S_OK;
}
VariantInit(&v);
hr = VariantChangeType(&v, &vCmd, 0, VT_BSTR);
if (!SUCCEEDED(hr)) {
return hr;
}
scriptPtr = Tcl_NewUnicodeObj(v.bstrVal, (int) SysStringLen(v.bstrVal));
Tcl_Preserve(interp);
Tcl_IncrRefCount(scriptPtr);
result = Tcl_EvalObjEx(interp, scriptPtr,
TCL_EVAL_DIRECT | TCL_EVAL_GLOBAL);
Tcl_DecrRefCount(scriptPtr);
if (pvResult != NULL) {
VariantInit(pvResult);
pvResult->vt = VT_BSTR;
pvResult->bstrVal = SysAllocString(Tcl_GetUnicode(
Tcl_GetObjResult(interp)));
}
if (result == TCL_ERROR) {
hr = DISP_E_EXCEPTION;
TkWinSend_SetExcepInfo(interp, pExcepInfo);
}
Tcl_Release(interp);
VariantClear(&v);
return hr;
}
static HRESULT
Send(
TkWinSendCom *obj,
VARIANT vCmd,
VARIANT *pvResult,
EXCEPINFO *pExcepInfo,
UINT *puArgErr)
{
HRESULT hr = S_OK;
int result = TCL_OK;
VARIANT v;
VariantInit(&v);
hr = VariantChangeType(&v, &vCmd, 0, VT_BSTR);
if (SUCCEEDED(hr)) {
if (obj->interp) {
Tcl_Obj *scriptPtr = Tcl_NewUnicodeObj(v.bstrVal,
(int)SysStringLen(v.bstrVal));
result = Tcl_EvalObjEx(obj->interp, scriptPtr,
TCL_EVAL_DIRECT | TCL_EVAL_GLOBAL);
if (pvResult) {
VariantInit(pvResult);
pvResult->vt = VT_BSTR;
pvResult->bstrVal = SysAllocString(
Tcl_GetUnicode(Tcl_GetObjResult(obj->interp)));
}
if (result == TCL_ERROR) {
hr = DISP_E_EXCEPTION;
SetExcepInfo(obj->interp, pExcepInfo);
}
}
VariantClear(&v);
}
return hr;
}
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 && ei.bstrSource != NULL) {
Tcl_Obj *opError, *opErrorCode, *opErrorInfo;
opError = Tcl_NewUnicodeObj(ei.bstrSource, -1);
Tcl_ListObjIndex(interp, opError, 0, &opErrorCode);
Tcl_SetObjErrorCode(interp, opErrorCode);
Tcl_ListObjIndex(interp, opError, 1, &opErrorInfo);
Tcl_AppendObjToErrorInfo(interp, opErrorInfo);
}
/*
* Clean up any COM allocated resources.
*/
SysFreeString(ei.bstrDescription);
SysFreeString(ei.bstrSource);
SysFreeString(ei.bstrHelpFile);
VariantClear(&vCmd);
return (SUCCEEDED(hr) ? TCL_OK : TCL_ERROR);
}
