/*
* tkWinSend.c --
*
* This file provides functions that implement the "send" command,
* allowing commands to be passed from interpreter to interpreter.
*
* Copyright (c) 1997 by Sun Microsystems, Inc.
* Copyright (c) 2003 Pat Thoyts <[email protected]>
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tkWinSend.c,v 1.25 2010/09/28 08:22:30 nijtmans Exp $
*/
#include "tkInt.h"
#include "tkWinSendCom.h"
/*
* Should be defined in WTypes.h but mingw 1.0 is missing them.
*/
#ifndef _ROTFLAGS_DEFINED
#define _ROTFLAGS_DEFINED
#define ROTFLAGS_REGISTRATIONKEEPSALIVE 0x01
#define ROTFLAGS_ALLOWANYCLIENT 0x02
#endif /* ! _ROTFLAGS_DEFINED */
#define TKWINSEND_CLASS_NAME "TclEval"
#define TKWINSEND_REGISTRATION_BASE L"TclEval"
#define MK_E_MONIKERALREADYREGISTERED \
MAKE_HRESULT(SEVERITY_ERROR, FACILITY_ITF, 0x02A1)
/*
* Package information structure. This is used to keep interpreter specific
* details for use when releasing the package resources upon interpreter
* deletion or package removal.
*/
typedef struct {
char *name; /* The registered application name */
DWORD cookie; /* ROT cookie returned on registration */
LPUNKNOWN obj; /* Interface for the registration object */
Tcl_Interp *interp;
Tcl_Command token; /* Winsend command token */
} RegisteredInterp;
typedef struct SendEvent {
Tcl_Event header;
Tcl_Interp *interp;
Tcl_Obj *cmdPtr;
} SendEvent;
#ifdef TK_SEND_ENABLED_ON_WINDOWS
typedef struct {
int initialized;
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
#endif
/*
* Functions internal to this file.
*/
#ifdef TK_SEND_ENABLED_ON_WINDOWS
static void CmdDeleteProc(ClientData clientData);
static void InterpDeleteProc(ClientData clientData,
Tcl_Interp *interp);
static void RevokeObjectRegistration(RegisteredInterp *riPtr);
#endif
static HRESULT BuildMoniker(const char *name, LPMONIKER *pmk);
#ifdef TK_SEND_ENABLED_ON_WINDOWS
static HRESULT RegisterInterp(const char *name,
RegisteredInterp *riPtr);
#endif
static int FindInterpreterObject(Tcl_Interp *interp,
const char *name, LPDISPATCH *ppdisp);
static int Send(LPDISPATCH pdispInterp, Tcl_Interp *interp,
int async, ClientData clientData, int objc,
Tcl_Obj *const objv[]);
static Tcl_Obj * Win32ErrorObj(HRESULT hrError);
static void SendTrace(const char *format, ...);
static Tcl_EventProc SendEventProc;
#if defined(DEBUG) || defined(_DEBUG)
#define TRACE SendTrace
#else
#define TRACE 1 ? ((void)0) : SendTrace
#endif
/*
*--------------------------------------------------------------
*
* Tk_SetAppName --
*
* This function is called to associate an ASCII name with a Tk
* application. If the application has already been named, the name
* replaces the old one.
*
* Results:
* The return value is the name actually given to the application. This
* will normally be the same as name, but if name was already in use for
* an application then a name of the form "name #2" will be chosen, with
* a high enough number to make the name unique.
*
* Side effects:
* Registration info is saved, thereby allowing the "send" command to be
* used later to invoke commands in the application. In addition, the
* "send" command is created in the application's interpreter. The
* registration will be removed automatically if the interpreter is
* deleted or the "send" command is removed.
*
*--------------------------------------------------------------
*/
const char *
Tk_SetAppName(
Tk_Window tkwin, /* Token for any window in the application to
* be named: it is just used to identify the
* application and the display. */
const char *name) /* The name that will be used to refer to the
* interpreter in later "send" commands. Must
* be globally unique. */
{
#ifndef TK_SEND_ENABLED_ON_WINDOWS
/*
* Temporarily disabled for bug #858822
*/
return name;
#else /* TK_SEND_ENABLED_ON_WINDOWS */
ThreadSpecificData *tsdPtr = NULL;
TkWindow *winPtr = (TkWindow *) tkwin;
RegisteredInterp *riPtr = NULL;
Tcl_Interp *interp;
HRESULT hr = S_OK;
interp = winPtr->mainPtr->interp;
tsdPtr = (ThreadSpecificData *)
Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
/*
* Initialise the COM library for this interpreter just once.
*/
if (tsdPtr->initialized == 0) {
hr = CoInitialize(0);
if (FAILED(hr)) {
Tcl_SetResult(interp,
"failed to initialize the COM library", TCL_STATIC);
return "";
}
tsdPtr->initialized = 1;
TRACE("Initialized COM library for interp 0x%08X\n", (long)interp);
}
/*
* If the interp hasn't been registered before then we need to create the
* registration structure and the COM object. If it has been registered
* already then we can reuse all and just register the new name.
*/
riPtr = Tcl_GetAssocData(interp, "tkWinSend::ri", NULL);
if (riPtr == NULL) {
LPUNKNOWN *objPtr;
riPtr = ckalloc(sizeof(RegisteredInterp));
memset(riPtr, 0, sizeof(RegisteredInterp));
riPtr->interp = interp;
objPtr = &riPtr->obj;
hr = TkWinSendCom_CreateInstance(interp, &IID_IUnknown,
(void **) objPtr);
Tcl_CreateObjCommand(interp, "send", Tk_SendObjCmd, riPtr,
CmdDeleteProc);
if (Tcl_IsSafe(interp)) {
Tcl_HideCommand(interp, "send", "send");
}
Tcl_SetAssocData(interp, "tkWinSend::ri", NULL, riPtr);
} else {
RevokeObjectRegistration(riPtr);
}
RegisterInterp(name, riPtr);
return (const char *) riPtr->name;
#endif /* TK_SEND_ENABLED_ON_WINDOWS */
}
/*
*----------------------------------------------------------------------
*
* TkGetInterpNames --
*
* This function is invoked to fetch a list of all the interpreter names
* currently registered for the display of a particular window.
*
* Results:
* A standard Tcl return value. Interp->result will be set to hold a list
* of all the interpreter names defined for tkwin's display. If an error
* occurs, then TCL_ERROR is returned and interp->result will hold an
* error message.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TkGetInterpNames(
Tcl_Interp *interp, /* Interpreter for returning a result. */
Tk_Window tkwin) /* Window whose display is to be used for the
* lookup. */
{
#ifndef TK_SEND_ENABLED_ON_WINDOWS
/*
* Temporarily disabled for bug #858822
*/
return TCL_OK;
#else /* TK_SEND_ENABLED_ON_WINDOWS */
LPRUNNINGOBJECTTABLE pROT = NULL;
LPCOLESTR oleszStub = TKWINSEND_REGISTRATION_BASE;
HRESULT hr = S_OK;
Tcl_Obj *objList = NULL;
int result = TCL_OK;
hr = GetRunningObjectTable(0, &pROT);
if (SUCCEEDED(hr)) {
IBindCtx* pBindCtx = NULL;
objList = Tcl_NewListObj(0, NULL);
hr = CreateBindCtx(0, &pBindCtx);
if (SUCCEEDED(hr)) {
IEnumMoniker* pEnum;
hr = pROT->lpVtbl->EnumRunning(pROT, &pEnum);
if (SUCCEEDED(hr)) {
IMoniker* pmk = NULL;
while (pEnum->lpVtbl->Next(pEnum, 1, &pmk, NULL) == S_OK) {
LPOLESTR olestr;
hr = pmk->lpVtbl->GetDisplayName(pmk, pBindCtx, NULL,
&olestr);
if (SUCCEEDED(hr)) {
IMalloc *pMalloc = NULL;
if (wcsncmp(olestr, oleszStub,
wcslen(oleszStub)) == 0) {
LPOLESTR p = olestr + wcslen(oleszStub);
if (*p) {
result = Tcl_ListObjAppendElement(interp,
objList, Tcl_NewUnicodeObj(p + 1, -1));
}
}
hr = CoGetMalloc(1, &pMalloc);
if (SUCCEEDED(hr)) {
pMalloc->lpVtbl->Free(pMalloc, (void*)olestr);
pMalloc->lpVtbl->Release(pMalloc);
}
}
pmk->lpVtbl->Release(pmk);
}
pEnum->lpVtbl->Release(pEnum);
}
pBindCtx->lpVtbl->Release(pBindCtx);
}
pROT->lpVtbl->Release(pROT);
}
if (FAILED(hr)) {
/*
* Expire the list if set.
*/
if (objList != NULL) {
Tcl_DecrRefCount(objList);
}
Tcl_SetObjResult(interp, Win32ErrorObj(hr));
result = TCL_ERROR;
}
if (result == TCL_OK) {
Tcl_SetObjResult(interp, objList);
}
return result;
#endif /* TK_SEND_ENABLED_ON_WINDOWS */
}
/*
*--------------------------------------------------------------
*
* Tk_SendCmd --
*
* This function is invoked to process the "send" Tcl command. See the
* user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*--------------------------------------------------------------
*/
int
Tk_SendObjCmd(
ClientData clientData, /* Information about sender (only dispPtr
* field is used). */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument strings. */
{
enum {
SEND_ASYNC, SEND_DISPLAYOF, SEND_LAST
};
static const char *const sendOptions[] = {
"-async", "-displayof", "--", NULL
};
int result = TCL_OK;
int i, optind, async = 0;
Tcl_Obj *displayPtr = NULL;
/*
* Process the command options.
*/
for (i = 1; i < objc; i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], sendOptions,
"option", 0, &optind) != TCL_OK) {
break;
}
if (optind == SEND_ASYNC) {
++async;
} else if (optind == SEND_DISPLAYOF) {
displayPtr = objv[++i];
} else if (optind == SEND_LAST) {
i++;
break;
}
}
/*
* Ensure we still have a valid command.
*/
if ((objc - i) < 2) {
Tcl_WrongNumArgs(interp, 1, objv,
"?-async? ?-displayof? ?--? interpName arg ?arg ...?");
result = TCL_ERROR;
}
/*
* We don't support displayPtr. See TIP #150.
*/
if (displayPtr) {
Tcl_SetResult(interp, "option not implemented: \"displayof\" is "
"not available for this platform.", TCL_STATIC);
result = TCL_ERROR;
}
/*
* Send the arguments to the foreign interp.
*/
/* FIX ME: we need to check for local interp */
if (result == TCL_OK) {
LPDISPATCH pdisp;
result = FindInterpreterObject(interp, Tcl_GetString(objv[i]), &pdisp);
if (result == TCL_OK) {
i++;
result = Send(pdisp, interp, async, clientData, objc-i, objv+i);
pdisp->lpVtbl->Release(pdisp);
}
}
return result;
}
/*
*--------------------------------------------------------------
*
* FindInterpreterObject --
*
* Search the set of objects currently registered with the Running Object
* Table for one which matches the registered name. Tk objects are named
* using BuildMoniker by always prefixing with TclEval.
*
* Results:
* If a matching object registration is found, then the registered
* IDispatch interface pointer is returned. If not, then an error message
* is placed in the interpreter and TCL_ERROR is returned.
*
* Side effects:
* None.
*
*--------------------------------------------------------------
*/
static int
FindInterpreterObject(
Tcl_Interp *interp,
const char *name,
LPDISPATCH *ppdisp)
{
LPRUNNINGOBJECTTABLE pROT = NULL;
int result = TCL_OK;
HRESULT hr = GetRunningObjectTable(0, &pROT);
if (SUCCEEDED(hr)) {
IBindCtx* pBindCtx = NULL;
hr = CreateBindCtx(0, &pBindCtx);
if (SUCCEEDED(hr)) {
LPMONIKER pmk = NULL;
hr = BuildMoniker(name, &pmk);
if (SUCCEEDED(hr)) {
IUnknown *pUnkInterp = NULL, **ppUnkInterp = &pUnkInterp;
hr = pROT->lpVtbl->IsRunning(pROT, pmk);
hr = pmk->lpVtbl->BindToObject(pmk, pBindCtx, NULL,
&IID_IUnknown, (void **) ppUnkInterp);
if (SUCCEEDED(hr)) {
hr = pUnkInterp->lpVtbl->QueryInterface(pUnkInterp,
&IID_IDispatch, (void **) ppdisp);
pUnkInterp->lpVtbl->Release(pUnkInterp);
} else {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp,
"no application named \"", name, "\"", NULL);
result = TCL_ERROR;
}
pmk->lpVtbl->Release(pmk);
}
pBindCtx->lpVtbl->Release(pBindCtx);
}
pROT->lpVtbl->Release(pROT);
}
if (FAILED(hr) && result == TCL_OK) {
Tcl_SetObjResult(interp, Win32ErrorObj(hr));
result = TCL_ERROR;
}
return result;
}
/*
*--------------------------------------------------------------
*
* CmdDeleteProc --
*
* This function is invoked by Tcl when the "send" command is deleted in
* an interpreter. It unregisters the interpreter.
*
* Results:
* None.
*
* Side effects:
* The interpreter given by riPtr is unregistered, the registration
* structure is free'd and the COM object unregistered and released.
*
*--------------------------------------------------------------
*/
#ifdef TK_SEND_ENABLED_ON_WINDOWS
static void
CmdDeleteProc(
ClientData clientData)
{
RegisteredInterp *riPtr = (RegisteredInterp *)clientData;
/*
* Lock the package structure in memory.
*/
Tcl_Preserve(clientData);
/*
* Revoke the ROT registration.
*/
RevokeObjectRegistration(riPtr);
/*
* Release the registration object.
*/
riPtr->obj->lpVtbl->Release(riPtr->obj);
riPtr->obj = NULL;
Tcl_DeleteAssocData(riPtr->interp, "tkWinSend::ri");
/*
* Unlock the package data structure.
*/
Tcl_Release(clientData);
ckfree(clientData);
}
/*
*--------------------------------------------------------------
*
* RevokeObjectRegistration --
*
* Releases the interpreters registration object from the Running Object
* Table.
*
* Results:
* None.
*
* Side effects:
* The stored cookie value is zeroed and the name is free'd and the
* pointer set to NULL.
*
*--------------------------------------------------------------
*/
static void
RevokeObjectRegistration(
RegisteredInterp *riPtr)
{
LPRUNNINGOBJECTTABLE pROT = NULL;
HRESULT hr = S_OK;
if (riPtr->cookie != 0) {
hr = GetRunningObjectTable(0, &pROT);
if (SUCCEEDED(hr)) {
hr = pROT->lpVtbl->Revoke(pROT, riPtr->cookie);
pROT->lpVtbl->Release(pROT);
riPtr->cookie = 0;
}
}
/*
* Release the name storage.
*/
if (riPtr->name != NULL) {
free(riPtr->name);
riPtr->name = NULL;
}
}
#endif
/*
* ----------------------------------------------------------------------
*
* InterpDeleteProc --
*
* This is called when the interpreter is deleted and used to unregister
* the COM libraries.
*
* Results:
* None.
*
* Side effects:
* None.
*
* ----------------------------------------------------------------------
*/
#ifdef TK_SEND_ENABLED_ON_WINDOWS
static void
InterpDeleteProc(
ClientData clientData,
Tcl_Interp *interp)
{
CoUninitialize();
}
#endif
/*
* ----------------------------------------------------------------------
*
* BuildMoniker --
*
* Construct a moniker from the given name. This ensures that all our
* monikers have the same prefix.
*
* Results:
* S_OK. If the name cannot be turned into a moniker then a COM error
* code is returned.
*
* Side effects:
* The moniker created is stored at the address given by ppmk.
*
* ----------------------------------------------------------------------
*/
static HRESULT
BuildMoniker(
const char *name,
LPMONIKER *ppmk)
{
LPMONIKER pmkClass = NULL;
HRESULT hr = CreateFileMoniker(TKWINSEND_REGISTRATION_BASE, &pmkClass);
if (SUCCEEDED(hr)) {
LPMONIKER pmkItem = NULL;
Tcl_DString dString;
Tcl_DStringInit(&dString);
Tcl_UtfToUniCharDString(name, -1, &dString);
hr = CreateFileMoniker((LPOLESTR)Tcl_DStringValue(&dString), &pmkItem);
Tcl_DStringFree(&dString);
if (SUCCEEDED(hr)) {
hr = pmkClass->lpVtbl->ComposeWith(pmkClass, pmkItem, FALSE, ppmk);
pmkItem->lpVtbl->Release(pmkItem);
}
pmkClass->lpVtbl->Release(pmkClass);
}
return hr;
}
/*
* ----------------------------------------------------------------------
*
* RegisterInterp --
*
* Attempts to register the provided name for this interpreter. If the
* given name is already in use, then a numeric suffix is appended as
* " #n" until we identify a unique name.
*
* Results:
* Returns S_OK if successful, else a COM error code.
*
* Side effects:
* Registration returns a cookie value which is stored. We also store a
* copy of the name.
*
* ----------------------------------------------------------------------
*/
#ifdef TK_SEND_ENABLED_ON_WINDOWS
static HRESULT
RegisterInterp(
const char *name,
RegisteredInterp *riPtr)
{
HRESULT hr = S_OK;
LPRUNNINGOBJECTTABLE pROT = NULL;
LPMONIKER pmk = NULL;
int i, offset;
const char *actualName = name;
Tcl_DString dString;
Tcl_DStringInit(&dString);
hr = GetRunningObjectTable(0, &pROT);
if (SUCCEEDED(hr)) {
offset = 0;
for (i = 1; SUCCEEDED(hr); i++) {
if (i > 1) {
if (i == 2) {
Tcl_DStringInit(&dString);
Tcl_DStringAppend(&dString, name, -1);
Tcl_DStringAppend(&dString, " #", 2);
offset = Tcl_DStringLength(&dString);
Tcl_DStringSetLength(&dString, offset+TCL_INTEGER_SPACE);
actualName = Tcl_DStringValue(&dString);
}
sprintf(Tcl_DStringValue(&dString) + offset, "%d", i);
}
hr = BuildMoniker(actualName, &pmk);
if (SUCCEEDED(hr)) {
hr = pROT->lpVtbl->Register(pROT,
ROTFLAGS_REGISTRATIONKEEPSALIVE,
riPtr->obj, pmk, &riPtr->cookie);
pmk->lpVtbl->Release(pmk);
}
if (hr == MK_S_MONIKERALREADYREGISTERED) {
pROT->lpVtbl->Revoke(pROT, riPtr->cookie);
} else if (hr == S_OK) {
break;
}
}
pROT->lpVtbl->Release(pROT);
}
if (SUCCEEDED(hr)) {
riPtr->name = strdup(actualName);
}
Tcl_DStringFree(&dString);
return hr;
}
#endif
/*
* ----------------------------------------------------------------------
*
* Send --
*
* Perform an interface call to the server object. We convert the Tcl
* arguments into a BSTR using 'concat'. The result should be a BSTR that
* we can set as the interp's result string.
*
* Results:
* None.
*
* Side effects:
* None.
*
* ----------------------------------------------------------------------
*/
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;
const 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);
}
/*
* ----------------------------------------------------------------------
*
* Win32ErrorObj --
*
* Returns a string object containing text from a COM or Win32 error code
*
* Results:
* A Tcl_Obj containing the Win32 error message.
*
* Side effects:
* Removed the error message from the COM threads error object.
*
* ----------------------------------------------------------------------
*/
static Tcl_Obj*
Win32ErrorObj(
HRESULT hrError)
{
LPTSTR lpBuffer = NULL, p = NULL;
TCHAR sBuffer[30];
Tcl_Obj* errPtr = NULL;
FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER | FORMAT_MESSAGE_FROM_SYSTEM
| FORMAT_MESSAGE_IGNORE_INSERTS, NULL, (DWORD)hrError,
LANG_NEUTRAL, (LPTSTR)&lpBuffer, 0, NULL);
if (lpBuffer == NULL) {
lpBuffer = sBuffer;
wsprintf(sBuffer, TEXT("Error Code: %08lX"), hrError);
}
if ((p = _tcsrchr(lpBuffer, TEXT('\r'))) != NULL) {
*p = TEXT('\0');
}
#ifdef _UNICODE
errPtr = Tcl_NewUnicodeObj(lpBuffer, (int)wcslen(lpBuffer));
#else
errPtr = Tcl_NewStringObj(lpBuffer, (int)strlen(lpBuffer));
#endif
if (lpBuffer != sBuffer) {
LocalFree((HLOCAL)lpBuffer);
}
return errPtr;
}
/*
* ----------------------------------------------------------------------
*
* SetErrorInfo --
*
* Convert the error information from a Tcl interpreter into a COM
* exception structure. This information is then registered with the COM
* thread exception object so that it can be used for rich error
* reporting by COM clients.
*
* Results:
* None.
*
* Side effects:
* The current COM thread has its error object modified.
*
* ----------------------------------------------------------------------
*/
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);
}
}
}
/*
* ----------------------------------------------------------------------
*
* TkWinSend_QueueCommand --
*
* Queue a script for asynchronous evaluation. This is called from the
* COM objects Async method.
*
* Results:
* None.
*
* Side effects:
* None.
*
* ----------------------------------------------------------------------
*/
int
TkWinSend_QueueCommand(
Tcl_Interp *interp,
Tcl_Obj *cmdPtr)
{
SendEvent *evPtr;
TRACE("SendQueueCommand()\n");
evPtr = ckalloc(sizeof(SendEvent));
evPtr->header.proc = SendEventProc;
evPtr->header.nextPtr = NULL;
evPtr->interp = interp;
Tcl_Preserve(evPtr->interp);
if (Tcl_IsShared(cmdPtr)) {
evPtr->cmdPtr = Tcl_DuplicateObj(cmdPtr);
} else {
evPtr->cmdPtr = cmdPtr;
Tcl_IncrRefCount(evPtr->cmdPtr);
}
Tcl_QueueEvent((Tcl_Event *)evPtr, TCL_QUEUE_TAIL);
return 0;
}
/*
* ----------------------------------------------------------------------
*
* SendEventProc --
*
* Handle a request for an asynchronous send. Nothing is returned to the
* caller so the result is discarded.
*
* Results:
* Returns 1 if the event was handled or 0 to indicate it has been
* deferred.
*
* Side effects:
* The target interpreter's result will be modified.
*
* ----------------------------------------------------------------------
*/
static int
SendEventProc(
Tcl_Event *eventPtr,
int flags)
{
int result = TCL_OK;
SendEvent *evPtr = (SendEvent *)eventPtr;
TRACE("SendEventProc\n");
result = Tcl_EvalObjEx(evPtr->interp, evPtr->cmdPtr,
TCL_EVAL_DIRECT | TCL_EVAL_GLOBAL);
Tcl_DecrRefCount(evPtr->cmdPtr);
Tcl_Release(evPtr->interp);
return 1; /* 1 to indicate the event has been handled */
}
/*
* ----------------------------------------------------------------------
*
* SendTrace --
*
* Provide trace information to the Windows debug stream. To use this -
* use the TRACE macro, which compiles to nothing when DEBUG is not
* defined.
*
* Results:
* None.
*
* Side effects:
* None.
*
* ----------------------------------------------------------------------
*/
static void
SendTrace(
const char *format, ...)
{
va_list args;
static char buffer[1024];
va_start(args, format);
_vsnprintf(buffer, 1023, format, args);
OutputDebugStringA(buffer);
va_end(args);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
