/* * tkWinSend.c -- * * This file provides procedures 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. * * RCS: @(#) $Id: tkWinSend.c,v 1.8 2003/12/16 21:57:57 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 /* *-------------------------------------------------------------- * * 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. * * 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(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. */ { 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; /* * Temporarily disabled for bug #858822 */ return name; /* * 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; } /* *---------------------------------------------------------------------- * * TkGetInterpNames -- * * This procedure 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(interp, tkwin) Tcl_Interp *interp; /* Interpreter for returning a result. */ Tk_Window tkwin; /* Window whose display is to be used * for the lookup. */ { LPRUNNINGOBJECTTABLE pROT = NULL; LPCOLESTR oleszStub = TKWINSEND_REGISTRATION_BASE; HRESULT hr = S_OK; Tcl_Obj *objList = NULL; int result = TCL_OK; /* * Temporarily disabled for bug #858822 */ return 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) { 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; } /* *-------------------------------------------------------------- * * 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 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; 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); 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 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) { 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; 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; } /* * ---------------------------------------------------------------------- * * 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, _T("Error Code: %08lX"), hrError); } if ((p = _tcsrchr(lpBuffer, _T('\r'))) != NULL) { *p = _T('\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; 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**)&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 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); }