/*
* tkWinSend.c --
*
* This file provides procedures 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 <patthoyts@users.sourceforge.net>
*
* 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.10 2005/10/14 11:59:19 patthoyts Exp $
*/
#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;
typedef struct {
int initialized;
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
static void CmdDeleteProc(ClientData clientData);
static void InterpDeleteProc(ClientData clientData, Tcl_Interp *interp);
static void RevokeObjectRegistration(RegisteredInterp *riPtr);
static HRESULT BuildMoniker(CONST char *name, LPMONIKER *pmk);
static HRESULT RegisterInterp(CONST char *name, RegisteredInterp *riPtr);
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 procedure 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(tkwin, name)
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. */
{
ThreadSpecificData *tsdPtr = NULL;
TkWindow *winPtr = (TkWindow *)tkwin;
RegisteredInterp *riPtr = NULL;
Tcl_Interp *interp;
HRESULT hr = S_OK;
interp = winPtr->mainPtr->interp;
/*
* Temporarily disabled for bug #858822
*/
return name;
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) {
riPtr = (RegisteredInterp *)ckalloc(sizeof(RegisteredInterp));
memset(riPtr, 0, sizeof(RegisteredInterp));
riPtr->interp = interp;
hr = TkWinSendCom_CreateInstance(interp, &IID_IUnknown,
(void **)&riPtr->obj);
Tcl_CreateObjCommand(interp, "send", Tk_SendObjCmd,
(ClientData)riPtr, CmdDeleteProc);
if (Tcl_IsSafe(interp)) {
Tcl_HideCommand(interp, "send", "send");
}
Tcl_SetAssocData(interp, "tkWinSend::ri", NULL, (ClientData)riPtr);
} else {
RevokeObjectRegistration(riPtr);
}
RegisterInterp(name, riPtr);
return (CONST char *)riPtr->name;
}
/*
*----------------------------------------------------------------------
*
* TkGetInterpNames --
*
* This procedure 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(interp, tkwin)
Tcl_Interp *interp; /* Interpreter for returning a result. */
Tk_Window tkwin; /* Window whose display is to be used
* for the lookup. */
{
LPRUNNINGOBJECTTABLE pROT = NULL;
LPCOLESTR oleszStub = TKWINSEND_REGISTRATION_BASE;
HRESULT hr = S_OK;
Tcl_Obj *objList = NULL;
int result = TCL_OK;
/*
* Temporarily disabled for bug #858822
*/
return 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, (ULONG*)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;
}
/*
*--------------------------------------------------------------
*
* Tk_SendCmd --
*
* This procedure 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, interp, objc, objv)
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 *sendOptions[] = {
"-async", "-displayof", "--", (CONST char *)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_SetStringObj(Tcl_GetObjResult(interp),
"option not implemented: \"displayof\" is not available "
"for this platform.", -1);
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;
hr = pROT->lpVtbl->IsRunning(pROT, pmk);
hr = pmk->lpVtbl->BindToObject(pmk, pBindCtx, NULL,
&IID_IUnknown, (void**)&punkInterp);
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 procedure 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.
*
*--------------------------------------------------------------
*/
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;
}
}
/*
* ----------------------------------------------------------------------
*
* InterpDeleteProc --
*
* This is called when the interpreter is deleted and used to
* unregister the COM libraries.
*
* Results:
* None.
*
* Side effects:
* None.
*
* ----------------------------------------------------------------------
*/
static void
InterpDeleteProc(ClientData clientData, Tcl_Interp *interp)
{
CoUninitialize();
}
/*
* ----------------------------------------------------------------------
*
* 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.
*
* ----------------------------------------------------------------------
*/
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;
}
/*
* ----------------------------------------------------------------------
*
* 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;
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,
NULL, (DWORD)hrError, LANG_NEUTRAL,
(LPTSTR)&lpBuffer, 0, NULL);
if (lpBuffer == NULL) {
lpBuffer = sBuffer;
wsprintf(sBuffer, _T("Error Code: %08lX"), hrError);
}
if ((p = _tcsrchr(lpBuffer, _T('\r'))) != NULL) {
*p = _T('\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;
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**)&pEI);
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 = (SendEvent *)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);
OutputDebugString(buffer);
va_end(args);
}