* win/makefile.vc: Implementation of TIP #150, "Provide

	* win/tkWinSend.c:    'send' command for Windows"
	* win/tkWinSendCom.h:
	* win/tkWinSendCom.c:

1 files changed, 871 insertions, 3 deletions

diff --git a/win/tkWinSend.c b/win/tkWinSend.c
index d2fe2f2..856e8f6 100644
--- a/win/tkWinSend.c
+++ b/win/tkWinSend.c
@@ -6,15 +6,74 @@
  *	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.3 2002/08/05 04:30:41 dgp Exp $
+ * RCS: @(#) $Id: tkWinSend.c,v 1.4 2003/09/26 23:59:26 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
 
 
 /*
@@ -52,7 +111,60 @@ Tk_SetAppName(tkwin, name)
 				 * "send" commands.  Must be globally
 				 * unique. */
 {
-    return name;
+    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;
+
+    /* 
+     * 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;
 }
 
 /*
@@ -82,5 +194,761 @@ TkGetInterpNames(interp, tkwin)
     Tk_Window tkwin;		/* Window whose display is to be used
 				 * for the lookup. */
 {
-    return TCL_OK;
+    LPRUNNINGOBJECTTABLE pROT = NULL;
+    LPCOLESTR oleszStub = TKWINSEND_REGISTRATION_BASE;
+    HRESULT hr = S_OK;
+    Tcl_Obj *objList;
+    int r = 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)
+				r = 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));
+        r = TCL_ERROR;
+    }
+    
+    if (r == TCL_OK)
+        Tcl_SetObjResult(interp, objList);
+    
+    return r;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * 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 r = TCL_OK;
+    int i, optind, async = 0;
+    HRESULT hr = S_OK;
+    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 ...?");
+        r = TCL_ERROR;
+    }
+
+    /*
+     * FIX ME: we don't support displayPtr.
+     */
+
+    if (displayPtr) {
+	Tcl_SetStringObj(Tcl_GetObjResult(interp),
+	    "option not implemented: \"displayof\" is not available "
+	    "for this platform.", -1);
+	r = TCL_ERROR;
+    }
+    
+    /* send the arguments to the foreign interp */
+    /* FIX ME: async and check for local interp */
+    if (r == TCL_OK) {
+	LPDISPATCH pdisp;
+	r = FindInterpreterObject(interp, Tcl_GetString(objv[i]), &pdisp);
+	if (r == TCL_OK) {
+	    i++;
+	    r = Send(pdisp, interp, async, clientData, (objc - i), &objv[i]);
+	    pdisp->lpVtbl->Release(pdisp);
+	}
+    }
+    
+    return r;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * 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 r = 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);
+		    r = TCL_ERROR;
+		}
+		
+		pmk->lpVtbl->Release(pmk);
+	    }
+	    pBindCtx->lpVtbl->Release(pBindCtx);
+	}
+	pROT->lpVtbl->Release(pROT);
+    }
+    if (FAILED(hr) && r == TCL_OK)
+    {
+	Tcl_SetObjResult(interp, Win32ErrorObj(hr));
+	r = TCL_ERROR;
+    }
+    return r;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * 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 clientData;	/* Pointer to the interp registration block */
+{
+    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;
+    
+    hr = GetRunningObjectTable(0, &pROT);
+    if (SUCCEEDED(hr)) {
+
+	Tcl_DStringInit(&dString);
+	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;
+	}
+	
+	Tcl_DStringFree(&dString);
+	pROT->lpVtbl->Release(pROT);
+    }
+
+    if (SUCCEEDED(hr))
+	riPtr->name = strdup(actualName);
+    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, Tcl_Interp *interp, 
+    int async, ClientData clientData, int objc, Tcl_Obj *CONST objv[])
+{
+    VARIANT vCmd, vResult;
+    DISPPARAMS dp;
+    EXCEPINFO ei;
+    UINT uiErr = 0;
+    HRESULT hr = S_OK, ehr = S_OK;
+    Tcl_Obj *cmd = NULL;
+    DISPID dispid;
+    RegisteredInterp *riPtr = (RegisteredInterp *)clientData;
+
+    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, 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, wcslen(lpBuffer));
+#else
+    errPtr = Tcl_NewStringObj(lpBuffer, 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);
+
+        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 r = TCL_OK;
+    SendEvent *evPtr = (SendEvent *)eventPtr;
+    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+    TRACE("SendEventProc\n");
+    
+    r = 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
+ *   tab-width: 8
+ *   c-indentation-style: tcltk
+ * End:
+ */