update to tcl/tk 8.6.7

1 files changed, 0 insertions, 992 deletions

diff --git a/tk8.6/win/tkWinSend.c b/tk8.6/win/tkWinSend.c
deleted file mode 100644
index 6c4731a..0000000
--- a/tk8.6/win/tkWinSend.c
+++ /dev/null
@@ -1,992 +0,0 @@
-/*
- * tkWinSend.c --
- *
- *	This file provides functions that implement the "send" command,
- *	allowing commands to be passed from interpreter to interpreter.
- *
- * Copyright (c) 1997 by Sun Microsystems, Inc.
- * Copyright (c) 2003 Pat Thoyts <patthoyts@users.sourceforge.net>
- *
- * See the file "license.terms" for information on usage and redistribution of
- * this file, and for a DISCLAIMER OF ALL WARRANTIES.
- */
-
-#include "tkInt.h"
-#include "tkWinSendCom.h"
-
-/*
- * Should be defined in WTypes.h but mingw 1.0 is missing them.
- */
-
-#ifndef _ROTFLAGS_DEFINED
-#define _ROTFLAGS_DEFINED
-#define ROTFLAGS_REGISTRATIONKEEPSALIVE 0x01
-#define ROTFLAGS_ALLOWANYCLIENT		0x02
-#endif /* ! _ROTFLAGS_DEFINED */
-
-#define TKWINSEND_CLASS_NAME		"TclEval"
-#define TKWINSEND_REGISTRATION_BASE	L"TclEval"
-
-#define MK_E_MONIKERALREADYREGISTERED \
-	MAKE_HRESULT(SEVERITY_ERROR, FACILITY_ITF, 0x02A1)
-
-/*
- * Package information structure. This is used to keep interpreter specific
- * details for use when releasing the package resources upon interpreter
- * deletion or package removal.
- */
-
-typedef struct {
-    char *name;			/* The registered application name */
-    DWORD cookie;		/* ROT cookie returned on registration */
-    LPUNKNOWN obj;		/* Interface for the registration object */
-    Tcl_Interp *interp;
-    Tcl_Command token;		/* Winsend command token */
-} RegisteredInterp;
-
-typedef struct SendEvent {
-    Tcl_Event header;
-    Tcl_Interp *interp;
-    Tcl_Obj *cmdPtr;
-} SendEvent;
-
-#ifdef TK_SEND_ENABLED_ON_WINDOWS
-typedef struct {
-    int initialized;
-} ThreadSpecificData;
-static Tcl_ThreadDataKey dataKey;
-#endif /* TK_SEND_ENABLED_ON_WINDOWS */
-
-/*
- * 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 /* TK_SEND_ENABLED_ON_WINDOWS */
-static HRESULT		BuildMoniker(const char *name, LPMONIKER *pmk);
-#ifdef TK_SEND_ENABLED_ON_WINDOWS
-static HRESULT		RegisterInterp(const char *name,
-			    RegisteredInterp *riPtr);
-#endif /* TK_SEND_ENABLED_ON_WINDOWS */
-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 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 /* DEBUG || _DEBUG */
-
-/*
- *--------------------------------------------------------------
- *
- * Tk_SetAppName --
- *
- *	This function is called to associate an ASCII name with a Tk
- *	application. If the application has already been named, the name
- *	replaces the old one.
- *
- * Results:
- *	The return value is the name actually given to the application. This
- *	will normally be the same as name, but if name was already in use for
- *	an application then a name of the form "name #2" will be chosen, with
- *	a high enough number to make the name unique.
- *
- * Side effects:
- *	Registration info is saved, thereby allowing the "send" command to be
- *	used later to invoke commands in the application. In addition, the
- *	"send" command is created in the application's interpreter. The
- *	registration will be removed automatically if the interpreter is
- *	deleted or the "send" command is removed.
- *
- *--------------------------------------------------------------
- */
-
-const char *
-Tk_SetAppName(
-    Tk_Window tkwin,		/* Token for any window in the application to
-				 * be named: it is just used to identify the
-				 * application and the display.  */
-    const char *name)		/* The name that will be used to refer to the
-				 * interpreter in later "send" commands. Must
-				 * be globally unique. */
-{
-#ifndef TK_SEND_ENABLED_ON_WINDOWS
-    /*
-     * Temporarily disabled for bug #858822
-     */
-
-    return name;
-#else /* TK_SEND_ENABLED_ON_WINDOWS */
-
-    ThreadSpecificData *tsdPtr = NULL;
-    TkWindow *winPtr = (TkWindow *) tkwin;
-    RegisteredInterp *riPtr = NULL;
-    Tcl_Interp *interp;
-    HRESULT hr = S_OK;
-
-    interp = winPtr->mainPtr->interp;
-    tsdPtr = 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_SetObjResult(interp, Tcl_NewStringObj(
-		    "failed to initialize the COM library", -1));
-	    Tcl_SetErrorCode(interp, "TK", "SEND", "COM", NULL);
-	    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 = ckalloc(sizeof(RegisteredInterp));
-	memset(riPtr, 0, sizeof(RegisteredInterp));
-	riPtr->interp = interp;
-
-	objPtr = &riPtr->obj;
-	hr = TkWinSendCom_CreateInstance(interp, &IID_IUnknown,
-		(void **) objPtr);
-
-	Tcl_CreateObjCommand(interp, "send", Tk_SendObjCmd, riPtr,
-		CmdDeleteProc);
-	if (Tcl_IsSafe(interp)) {
-	    Tcl_HideCommand(interp, "send", "send");
-	}
-	Tcl_SetAssocData(interp, "tkWinSend::ri", NULL, riPtr);
-    } else {
-	RevokeObjectRegistration(riPtr);
-    }
-
-    RegisterInterp(name, riPtr);
-    return (const char *) riPtr->name;
-#endif /* TK_SEND_ENABLED_ON_WINDOWS */
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TkGetInterpNames --
- *
- *	This function is invoked to fetch a list of all the interpreter names
- *	currently registered for the display of a particular window.
- *
- * Results:
- *	A standard Tcl return value. Interp->result will be set to hold a list
- *	of all the interpreter names defined for tkwin's display. If an error
- *	occurs, then TCL_ERROR is returned and interp->result will hold an
- *	error message.
- *
- * Side effects:
- *	None.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TkGetInterpNames(
-    Tcl_Interp *interp,		/* Interpreter for returning a result. */
-    Tk_Window tkwin)		/* Window whose display is to be used for the
-				 * lookup. */
-{
-#ifndef TK_SEND_ENABLED_ON_WINDOWS
-    /*
-     * Temporarily disabled for bug #858822
-     */
-
-    return TCL_OK;
-#else /* TK_SEND_ENABLED_ON_WINDOWS */
-
-    LPRUNNINGOBJECTTABLE pROT = NULL;
-    LPCOLESTR oleszStub = TKWINSEND_REGISTRATION_BASE;
-    HRESULT hr = S_OK;
-    Tcl_Obj *objList = NULL;
-    int result = TCL_OK;
-
-    hr = GetRunningObjectTable(0, &pROT);
-    if (SUCCEEDED(hr)) {
-	IBindCtx* pBindCtx = NULL;
-	objList = Tcl_NewListObj(0, NULL);
-	hr = CreateBindCtx(0, &pBindCtx);
-
-	if (SUCCEEDED(hr)) {
-	    IEnumMoniker* pEnum;
-
-	    hr = pROT->lpVtbl->EnumRunning(pROT, &pEnum);
-	    if (SUCCEEDED(hr)) {
-		IMoniker* pmk = NULL;
-
-		while (pEnum->lpVtbl->Next(pEnum, 1, &pmk, NULL) == S_OK) {
-		    LPOLESTR olestr;
-
-		    hr = pmk->lpVtbl->GetDisplayName(pmk, pBindCtx, NULL,
-			    &olestr);
-		    if (SUCCEEDED(hr)) {
-			IMalloc *pMalloc = NULL;
-
-			if (wcsncmp(olestr, oleszStub,
-				wcslen(oleszStub)) == 0) {
-			    LPOLESTR p = olestr + wcslen(oleszStub);
-
-			    if (*p) {
-				result = Tcl_ListObjAppendElement(interp,
-					objList, Tcl_NewUnicodeObj(p + 1, -1));
-			    }
-			}
-
-			hr = CoGetMalloc(1, &pMalloc);
-			if (SUCCEEDED(hr)) {
-			    pMalloc->lpVtbl->Free(pMalloc, (void*)olestr);
-			    pMalloc->lpVtbl->Release(pMalloc);
-			}
-		    }
-		    pmk->lpVtbl->Release(pmk);
-		}
-		pEnum->lpVtbl->Release(pEnum);
-	    }
-	    pBindCtx->lpVtbl->Release(pBindCtx);
-	}
-	pROT->lpVtbl->Release(pROT);
-    }
-
-    if (FAILED(hr)) {
-	/*
-	 * Expire the list if set.
-	 */
-
-	if (objList != NULL) {
-	    Tcl_DecrRefCount(objList);
-	}
-	Tcl_SetObjResult(interp, TkWin32ErrorObj(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 *const 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_GetIndexFromObjStruct(interp, objv[i], sendOptions,
-		sizeof(char *), "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_SetObjResult(interp, Tcl_NewStringObj(
-		"option not implemented: \"displayof\" is not available"
-		" for this platform.", -1));
-	Tcl_SetErrorCode(interp, "TK", "SEND", "DISPLAYOF_WIN", NULL);
-	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_SetObjResult(interp, Tcl_ObjPrintf(
-			    "no application named \"%s\"", name));
-		    Tcl_SetErrorCode(interp, "TK", "LOOKUP", "APPLICATION",
-			    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, TkWin32ErrorObj(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 /* TK_SEND_ENABLED_ON_WINDOWS */
-
-/*
- * ----------------------------------------------------------------------
- *
- * 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 /* TK_SEND_ENABLED_ON_WINDOWS */
-
-/*
- * ----------------------------------------------------------------------
- *
- * 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 /* TK_SEND_ENABLED_ON_WINDOWS */
-
-/*
- * ----------------------------------------------------------------------
- *
- * 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 && ei.bstrSource != NULL) {
-	Tcl_Obj *opError, *opErrorCode, *opErrorInfo;
-
-	opError = Tcl_NewUnicodeObj(ei.bstrSource, -1);
-	Tcl_ListObjIndex(interp, opError, 0, &opErrorCode);
-	Tcl_SetObjErrorCode(interp, opErrorCode);
-	Tcl_ListObjIndex(interp, opError, 1, &opErrorInfo);
-	Tcl_AppendObjToErrorInfo(interp, opErrorInfo);
-    }
-
-    /*
-     * Clean up any COM allocated resources.
-     */
-
-    SysFreeString(ei.bstrDescription);
-    SysFreeString(ei.bstrSource);
-    SysFreeString(ei.bstrHelpFile);
-    VariantClear(&vCmd);
-
-    return (SUCCEEDED(hr) ? TCL_OK : TCL_ERROR);
-}
-
-/*
- * ----------------------------------------------------------------------
- *
- * TkWinSend_SetExcepInfo --
- *
- *	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
-TkWinSend_SetExcepInfo(
-    Tcl_Interp *interp,
-    EXCEPINFO *pExcepInfo)
-{
-    Tcl_Obj *opError, *opErrorInfo, *opErrorCode;
-    ICreateErrorInfo *pCEI;
-    IErrorInfo *pEI, **ppEI = &pEI;
-    HRESULT hr;
-
-    if (!pExcepInfo) {
-	return;
-    }
-
-    opError = Tcl_GetObjResult(interp);
-    opErrorInfo = Tcl_GetVar2Ex(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY);
-    opErrorCode = Tcl_GetVar2Ex(interp, "errorCode", NULL, TCL_GLOBAL_ONLY);
-
-    /*
-     * Pack the trace onto the end of the Tcl exception descriptor.
-     */
-
-    opErrorCode = Tcl_DuplicateObj(opErrorCode);
-    Tcl_IncrRefCount(opErrorCode);
-    Tcl_ListObjAppendElement(interp, opErrorCode, opErrorInfo);
-    /* TODO: Handle failure to append */
-
-    pExcepInfo->bstrDescription = SysAllocString(Tcl_GetUnicode(opError));
-    pExcepInfo->bstrSource = SysAllocString(Tcl_GetUnicode(opErrorCode));
-    Tcl_DecrRefCount(opErrorCode);
-    pExcepInfo->scode = E_FAIL;
-
-    hr = CreateErrorInfo(&pCEI);
-    if (!SUCCEEDED(hr)) {
-	return;
-    }
-
-    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 = 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)
-{
-    SendEvent *evPtr = (SendEvent *)eventPtr;
-
-    TRACE("SendEventProc\n");
-
-    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);
-    OutputDebugStringA(buffer);
-    va_end(args);
-}
-
-/*
- * Local Variables:
- * mode: c
- * c-basic-offset: 4
- * fill-column: 78
- * End:
- */