/* * 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 * * 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%" TCL_Z_MODIFIER "x\n", (size_t)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) { Tcl_DString ds; Tcl_DStringInit(&ds); Tcl_WCharToUtfDString(p + 1, wcslen(p + 1), &ds); result = Tcl_ListObjAppendElement(interp, objList, Tcl_NewStringObj(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds))); Tcl_DStringFree(&ds); } } 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_UtfToWCharDString(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; Tcl_DString ds; const char *src; 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; src = Tcl_GetString(cmd); Tcl_DStringInit(&ds); vCmd.bstrVal = SysAllocString(Tcl_UtfToWCharDString(src, cmd->length, &ds)); Tcl_DStringFree(&ds); 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_DStringInit(&ds); Tcl_WCharToUtfDString(vResult.bstrVal, SysStringLen(vResult.bstrVal), &ds); Tcl_DStringResult(interp, &ds); } /* * 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; Tcl_DStringInit(&ds); Tcl_WCharToUtfDString(ei.bstrSource, SysStringLen(ei.bstrSource), &ds); opError = Tcl_NewStringObj(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)); Tcl_DStringFree(&ds); 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; Tcl_DString ds; const char *src; 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 */ src = Tcl_GetString(opError); Tcl_DStringInit(&ds); pExcepInfo->bstrDescription = SysAllocString(Tcl_UtfToWCharDString(src, opError->length, &ds)); Tcl_DStringFree(&ds); src = Tcl_GetString(opErrorCode); Tcl_DStringInit(&ds); pExcepInfo->bstrSource = SysAllocString(Tcl_UtfToWCharDString(src, opErrorCode->length, &ds)); Tcl_DStringFree(&ds); 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: */