path: root/win/tkWinSend.c

/*
 * 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 <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.17 2008/10/05 18:22:22 dkf 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);
#endif
static void		RevokeObjectRegistration(RegisteredInterp *riPtr);
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 = (RegisteredInterp *) 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 *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);
}
#endif

/*
 *--------------------------------------------------------------
 *
 * 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.
 *
 * ----------------------------------------------------------------------
 */

#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;
	    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, **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 = (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);
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */