summaryrefslogtreecommitdiffstats
path: root/win/tkWinSend.c
diff options
context:
space:
mode:
Diffstat (limited to 'win/tkWinSend.c')
-rw-r--r--win/tkWinSend.c874
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:
+ */