summaryrefslogtreecommitdiffstats
path: root/win/tkWinSend.c
diff options
context:
space:
mode:
Diffstat (limited to 'win/tkWinSend.c')
-rw-r--r--win/tkWinSend.c1044
1 files changed, 1005 insertions, 39 deletions
diff --git a/win/tkWinSend.c b/win/tkWinSend.c
index 781aa5d..dfece32 100644
--- a/win/tkWinSend.c
+++ b/win/tkWinSend.c
@@ -1,56 +1,195 @@
-/*
+/*
* tkWinSend.c --
*
- * This file provides procedures that implement the "send"
- * command, allowing commands to be passed from interpreter
- * to interpreter.
+ * 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.
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
-#include "tkPort.h"
#include "tkInt.h"
+#include "tkWinSendCom.h"
+
+#ifdef _MSC_VER
+#define vsnprintf _vsnprintf
+#endif
+
+/*
+ * 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);
+static void RevokeObjectRegistration(RegisteredInterp *riPtr);
+#endif
+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 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.
+ * 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.
+ * 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.
+ * 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. */
+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 */
}
/*
@@ -58,15 +197,14 @@ Tk_SetAppName(tkwin, name)
*
* TkGetInterpNames --
*
- * This procedure is invoked to fetch a list of all the
- * interpreter names currently registered for the display
- * of a particular window.
+ * 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.
+ * 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.
@@ -75,10 +213,838 @@ Tk_SetAppName(tkwin, name)
*/
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. */
+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_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, **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);
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * 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;
+ }
+}
+#endif
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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, TEXT("Error Code: %08lX"), hrError);
+ }
+
+ if ((p = _tcsrchr(lpBuffer, TEXT('\r'))) != NULL) {
+ *p = TEXT('\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:
+ */