/* 
 * 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.8 2003/12/16 21:57:57 patthoyts Exp $
 */

#include "tkPort.h"
#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;

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;
    TkWindow *winPtr = (TkWindow *)tkwin;
    RegisteredInterp *riPtr = NULL;
    Tcl_Interp *interp;
    HRESULT hr = S_OK;

    tsdPtr = TCL_TSD_INIT(&dataKey);
    interp = winPtr->mainPtr->interp;

    /*
     * Temporarily disabled for bug #858822
     */
    return name;

    /* 
     * 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);
}

