diff options
Diffstat (limited to 'win/tkWinSend.c')
| -rw-r--r-- | win/tkWinSend.c | 874 |
1 files changed, 871 insertions, 3 deletions
diff --git a/win/tkWinSend.c b/win/tkWinSend.c index d2fe2f2..856e8f6 100644 --- a/win/tkWinSend.c +++ b/win/tkWinSend.c @@ -6,15 +6,74 @@ * to interpreter. * * Copyright (c) 1997 by Sun Microsystems, Inc. + * Copyright (c) 2003 Pat Thoyts <patthoyts@users.sourceforge.net> * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tkWinSend.c,v 1.3 2002/08/05 04:30:41 dgp Exp $ + * RCS: @(#) $Id: tkWinSend.c,v 1.4 2003/09/26 23:59:26 patthoyts Exp $ */ #include "tkPort.h" #include "tkInt.h" +#include "tkWinSendCom.h" + +/* Should be defined in WTypes.h but mingw 1.0 is missing them */ +#ifndef _ROTFLAGS_DEFINED +#define _ROTFLAGS_DEFINED +#define ROTFLAGS_REGISTRATIONKEEPSALIVE 0x01 +#define ROTFLAGS_ALLOWANYCLIENT 0x02 +#endif /* ! _ROTFLAGS_DEFINED */ + +#define TKWINSEND_CLASS_NAME "TclEval" +#define TKWINSEND_REGISTRATION_BASE L"TclEval" + +#define MK_E_MONIKERALREADYREGISTERED \ + MAKE_HRESULT(SEVERITY_ERROR, FACILITY_ITF, 0x02A1) + +/* Package information structure. + * This is used to keep interpreter specific details for use when releasing + * the package resources upon interpreter deletion or package removal. + */ +typedef struct { + char *name; /* the registered application name */ + DWORD cookie; /* ROT cookie returned on registration */ + LPUNKNOWN obj; /* Interface for the registration object */ + Tcl_Interp *interp; + Tcl_Command token; /* Winsend command token */ +} RegisteredInterp; + +typedef struct SendEvent { + Tcl_Event header; + Tcl_Interp *interp; + Tcl_Obj *cmdPtr; +} SendEvent; + +typedef struct { + int initialized; +} ThreadSpecificData; +static Tcl_ThreadDataKey dataKey; + +static void CmdDeleteProc(ClientData clientData); +static void InterpDeleteProc(ClientData clientData, Tcl_Interp *interp); +static void RevokeObjectRegistration(RegisteredInterp *riPtr); +static HRESULT BuildMoniker(CONST char *name, LPMONIKER *pmk); +static HRESULT RegisterInterp(CONST char *name, RegisteredInterp *riPtr); +static int FindInterpreterObject(Tcl_Interp *interp, CONST char *name, + LPDISPATCH *ppdisp); +static int Send(LPDISPATCH pdispInterp, Tcl_Interp *interp, int async, + ClientData clientData, int objc, Tcl_Obj *CONST objv[]); +static Tcl_Obj* Win32ErrorObj(HRESULT hrError); +static void SendTrace(const char *format, ...); + +static Tcl_EventProc SendEventProc; + + +#if defined(DEBUG) || defined(_DEBUG) +#define TRACE SendTrace +#else +#define TRACE 1 ? ((void)0) : SendTrace +#endif /* @@ -52,7 +111,60 @@ Tk_SetAppName(tkwin, name) * "send" commands. Must be globally * unique. */ { - return name; + ThreadSpecificData *tsdPtr; + TkWindow *winPtr = (TkWindow *)tkwin; + RegisteredInterp *riPtr = NULL; + Tcl_Interp *interp; + HRESULT hr = S_OK; + + tsdPtr = TCL_TSD_INIT(&dataKey); + interp = winPtr->mainPtr->interp; + + /* + * Initialise the COM library for this interpreter just once. + */ + if (tsdPtr->initialized == 0) { + hr = CoInitialize(0); + if (FAILED(hr)) { + Tcl_SetResult(interp, + "failed to initialize the COM library", TCL_STATIC); + return ""; + } + tsdPtr->initialized = 1; + TRACE("Initialized COM library for interp 0x%08X\n", (long)interp); + } + + /* + * If the interp hasn't been registered before then we need to create + * the registration structure and the COM object. If it has been + * registered already then we can reuse all and just register the new + * name. + */ + + riPtr = Tcl_GetAssocData(interp, "tkWinSend::ri", NULL); + if (riPtr == NULL) { + + riPtr = (RegisteredInterp *)ckalloc(sizeof(RegisteredInterp)); + memset(riPtr, 0, sizeof(RegisteredInterp)); + riPtr->interp = interp; + + hr = TkWinSendCom_CreateInstance(interp, &IID_IUnknown, + (void **)&riPtr->obj); + + Tcl_CreateObjCommand(interp, "send", Tk_SendObjCmd, + (ClientData)riPtr, CmdDeleteProc); + if (Tcl_IsSafe(interp)) { + Tcl_HideCommand(interp, "send", "send"); + } + Tcl_SetAssocData(interp, "tkWinSend::ri", NULL, (ClientData)riPtr); + + } else { + + RevokeObjectRegistration(riPtr); + } + + RegisterInterp(name, riPtr); + return (CONST char *)riPtr->name; } /* @@ -82,5 +194,761 @@ TkGetInterpNames(interp, tkwin) Tk_Window tkwin; /* Window whose display is to be used * for the lookup. */ { - return TCL_OK; + LPRUNNINGOBJECTTABLE pROT = NULL; + LPCOLESTR oleszStub = TKWINSEND_REGISTRATION_BASE; + HRESULT hr = S_OK; + Tcl_Obj *objList; + int r = TCL_OK; + + hr = GetRunningObjectTable(0, &pROT); + if(SUCCEEDED(hr)) + { + IBindCtx* pBindCtx = NULL; + objList = Tcl_NewListObj(0, NULL); + hr = CreateBindCtx(0, &pBindCtx); + if (SUCCEEDED(hr)) + { + + IEnumMoniker* pEnum; + hr = pROT->lpVtbl->EnumRunning(pROT, &pEnum); + if(SUCCEEDED(hr)) + { + IMoniker* pmk = NULL; + while (pEnum->lpVtbl->Next(pEnum, 1, &pmk, (ULONG*)NULL) == S_OK) + { + LPOLESTR olestr; + hr = pmk->lpVtbl->GetDisplayName(pmk, pBindCtx, NULL, &olestr); + if (SUCCEEDED(hr)) + { + IMalloc *pMalloc = NULL; + + if (wcsncmp(olestr, oleszStub, wcslen(oleszStub)) == 0) + { + LPOLESTR p = olestr + wcslen(oleszStub); + if (*p) + r = Tcl_ListObjAppendElement(interp, objList, Tcl_NewUnicodeObj(p + 1, -1)); + } + + hr = CoGetMalloc(1, &pMalloc); + if (SUCCEEDED(hr)) + { + pMalloc->lpVtbl->Free(pMalloc, (void*)olestr); + pMalloc->lpVtbl->Release(pMalloc); + } + } + pmk->lpVtbl->Release(pmk); + } + pEnum->lpVtbl->Release(pEnum); + } + pBindCtx->lpVtbl->Release(pBindCtx); + } + pROT->lpVtbl->Release(pROT); + } + + if (FAILED(hr)) { + /* expire the list if set */ + if (objList != NULL) { + Tcl_DecrRefCount(objList); + } + Tcl_SetObjResult(interp, Win32ErrorObj(hr)); + r = TCL_ERROR; + } + + if (r == TCL_OK) + Tcl_SetObjResult(interp, objList); + + return r; +} + +/* + *-------------------------------------------------------------- + * + * Tk_SendCmd -- + * + * This procedure is invoked to process the "send" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +int +Tk_SendObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Information about sender (only + * dispPtr field is used). */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument strings. */ +{ + enum { + SEND_ASYNC, SEND_DISPLAYOF, SEND_LAST + }; + static CONST char *sendOptions[] = { + "-async", "-displayof", "--", (CONST char *)NULL + }; + int r = TCL_OK; + int i, optind, async = 0; + HRESULT hr = S_OK; + Tcl_Obj *displayPtr = NULL; + + /* process the command options */ + for (i = 1; i < objc; i++) { + if (Tcl_GetIndexFromObj(interp, objv[i], sendOptions, + "option", 0, &optind) != TCL_OK) { + break; + } + if (optind == SEND_ASYNC) { + ++async; + } else if (optind == SEND_DISPLAYOF) { + displayPtr = objv[++i]; + } else if (optind == SEND_LAST) { + i++; + break; + } + } + + /* ensure we still have a valid command */ + if ((objc - i) < 2) { + Tcl_WrongNumArgs(interp, 1, objv, + "?-async? ?-displayof? ?--? interpName arg ?arg ...?"); + r = TCL_ERROR; + } + + /* + * FIX ME: we don't support displayPtr. + */ + + if (displayPtr) { + Tcl_SetStringObj(Tcl_GetObjResult(interp), + "option not implemented: \"displayof\" is not available " + "for this platform.", -1); + r = TCL_ERROR; + } + + /* send the arguments to the foreign interp */ + /* FIX ME: async and check for local interp */ + if (r == TCL_OK) { + LPDISPATCH pdisp; + r = FindInterpreterObject(interp, Tcl_GetString(objv[i]), &pdisp); + if (r == TCL_OK) { + i++; + r = Send(pdisp, interp, async, clientData, (objc - i), &objv[i]); + pdisp->lpVtbl->Release(pdisp); + } + } + + return r; +} + +/* + *-------------------------------------------------------------- + * + * FindInterpreterObject -- + * + * Search the set of objects currently registered with the + * Running Object Table for one which matches the registered + * name. Tk objects are named using BuildMoniker by always + * prefixing with TclEval. + * + * Results: + * If a matching object registration is found, then the + * registered IDispatch interface pointer is returned. + * If not, then an error message is placed in the interpreter + * and TCL_ERROR is returned. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static int +FindInterpreterObject(Tcl_Interp *interp, CONST char *name, LPDISPATCH *ppdisp) +{ + LPRUNNINGOBJECTTABLE pROT = NULL; + int r = TCL_OK; + HRESULT hr = GetRunningObjectTable(0, &pROT); + if (SUCCEEDED(hr)) + { + IBindCtx* pBindCtx = NULL; + hr = CreateBindCtx(0, &pBindCtx); + if (SUCCEEDED(hr)) + { + LPMONIKER pmk = NULL; + hr = BuildMoniker(name, &pmk); + if (SUCCEEDED(hr)) + { + IUnknown* punkInterp = NULL; + hr = pROT->lpVtbl->IsRunning(pROT, pmk); + hr = pmk->lpVtbl->BindToObject(pmk, pBindCtx, NULL, + &IID_IUnknown, (void**)&punkInterp); + if (SUCCEEDED(hr)) { + hr = punkInterp->lpVtbl->QueryInterface(punkInterp, + &IID_IDispatch, (void**)ppdisp); + punkInterp->lpVtbl->Release(punkInterp); + + } else { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, + "no application named \"", name, "\"", NULL); + r = TCL_ERROR; + } + + pmk->lpVtbl->Release(pmk); + } + pBindCtx->lpVtbl->Release(pBindCtx); + } + pROT->lpVtbl->Release(pROT); + } + if (FAILED(hr) && r == TCL_OK) + { + Tcl_SetObjResult(interp, Win32ErrorObj(hr)); + r = TCL_ERROR; + } + return r; +} + +/* + *-------------------------------------------------------------- + * + * CmdDeleteProc -- + * + * This procedure is invoked by Tcl when the "send" command + * is deleted in an interpreter. It unregisters the interpreter. + * + * Results: + * None. + * + * Side effects: + * The interpreter given by riPtr is unregistered, the + * registration structure is free'd and the COM object + * unregistered and released. + * + *-------------------------------------------------------------- + */ + +static void +CmdDeleteProc(clientData) + ClientData clientData; /* Pointer to the interp registration block */ +{ + RegisteredInterp *riPtr = (RegisteredInterp *)clientData; + + /* Lock the package structure in memory */ + Tcl_Preserve(clientData); + + /* Revoke the ROT registration */ + RevokeObjectRegistration(riPtr); + + /* Release the registration object */ + riPtr->obj->lpVtbl->Release(riPtr->obj); + riPtr->obj = NULL; + + Tcl_DeleteAssocData(riPtr->interp, "tkWinSend::ri"); + + /* unlock the package data structure. */ + Tcl_Release(clientData); + + ckfree(clientData); +} + +/* + *-------------------------------------------------------------- + * + * RevokeObjectRegistration -- + * + * Releases the interpreters registration object from the + * Running Object Table. + * + * Results: + * None. + * + * Side effects: + * The stored cookie value is zeroed and the name is free'd + * and the pointer set to NULL. + * + *-------------------------------------------------------------- + */ + +static void +RevokeObjectRegistration(RegisteredInterp *riPtr) +{ + LPRUNNINGOBJECTTABLE pROT = NULL; + HRESULT hr = S_OK; + if (riPtr->cookie != 0) { + hr = GetRunningObjectTable(0, &pROT); + if (SUCCEEDED(hr)) { + hr = pROT->lpVtbl->Revoke(pROT, riPtr->cookie); + pROT->lpVtbl->Release(pROT); + riPtr->cookie = 0; + } + } + + /* release the name storage */ + if (riPtr->name != NULL) { + free(riPtr->name); + riPtr->name = NULL; + } +} + +/* + * ---------------------------------------------------------------------- + * + * InterpDeleteProc -- + * + * This is called when the interpreter is deleted and used to + * unregister the COM libraries. + * + * Results: + * None. + * + * Side effects: + * None. + * + * ---------------------------------------------------------------------- + */ + +static void +InterpDeleteProc(ClientData clientData, Tcl_Interp *interp) +{ + CoUninitialize(); +} + +/* + * ---------------------------------------------------------------------- + * + * BuildMoniker -- + * + * Construct a moniker from the given name. This ensures that all our + * monikers have the same prefix. + * + * Results: + * S_OK. If the name cannot be turned into a moniker then a + * COM error code is returned. + * + * Side effects: + * The moniker created is stored at the address given by ppmk. + * + * ---------------------------------------------------------------------- + */ + +static HRESULT +BuildMoniker(CONST char *name, LPMONIKER *ppmk) +{ + LPMONIKER pmkClass = NULL; + HRESULT hr = CreateFileMoniker(TKWINSEND_REGISTRATION_BASE, &pmkClass); + if (SUCCEEDED(hr)) { + LPMONIKER pmkItem = NULL; + Tcl_DString dString; + + Tcl_DStringInit(&dString); + Tcl_UtfToUniCharDString(name, -1, &dString); + hr = CreateFileMoniker((LPOLESTR)Tcl_DStringValue(&dString), &pmkItem); + Tcl_DStringFree(&dString); + if (SUCCEEDED(hr)) { + hr = pmkClass->lpVtbl->ComposeWith(pmkClass, pmkItem, FALSE, ppmk); + pmkItem->lpVtbl->Release(pmkItem); + } + pmkClass->lpVtbl->Release(pmkClass); + } + return hr; +} + +/* + * ---------------------------------------------------------------------- + * + * RegisterInterp -- + * + * Attempts to register the provided name for this interpreter. + * If the given name is already in use, then a numeric suffix is + * appended as " #n" until we identify a unique name. + * + * Results: + * Returns S_OK if successful, else a COM error code. + * + * Side effects: + * Registration returns a cookie value which is stored. We also store + * a copy of the name. + * + * ---------------------------------------------------------------------- + */ + +static HRESULT +RegisterInterp(CONST char *name, RegisteredInterp *riPtr) +{ + HRESULT hr = S_OK; + LPRUNNINGOBJECTTABLE pROT = NULL; + LPMONIKER pmk = NULL; + int i, offset; + CONST char *actualName = name; + Tcl_DString dString; + + hr = GetRunningObjectTable(0, &pROT); + if (SUCCEEDED(hr)) { + + Tcl_DStringInit(&dString); + offset = 0; + + for (i = 1; SUCCEEDED(hr); i++) { + if (i > 1) { + if (i == 2) { + Tcl_DStringInit(&dString); + Tcl_DStringAppend(&dString, name, -1); + Tcl_DStringAppend(&dString, " #", 2); + offset = Tcl_DStringLength(&dString); + Tcl_DStringSetLength(&dString, offset+TCL_INTEGER_SPACE); + actualName = Tcl_DStringValue(&dString); + } + sprintf(Tcl_DStringValue(&dString) + offset, "%d", i); + } + + hr = BuildMoniker(actualName, &pmk); + if (SUCCEEDED(hr)) { + + hr = pROT->lpVtbl->Register(pROT, + ROTFLAGS_REGISTRATIONKEEPSALIVE, + riPtr->obj, pmk, &riPtr->cookie); + + pmk->lpVtbl->Release(pmk); + } + + if (hr == MK_S_MONIKERALREADYREGISTERED) + pROT->lpVtbl->Revoke(pROT, riPtr->cookie); + else if (hr == S_OK) + break; + } + + Tcl_DStringFree(&dString); + pROT->lpVtbl->Release(pROT); + } + + if (SUCCEEDED(hr)) + riPtr->name = strdup(actualName); + return hr; +} + +/* + * ---------------------------------------------------------------------- + * + * Send -- + * + * Perform an interface call to the server object. We convert the + * Tcl arguments into a BSTR using 'concat'. The result should be a + * BSTR that we can set as the interp's result string. + * + * Results: + * None. + * + * Side effects: + * None. + * + * ---------------------------------------------------------------------- + */ + +static int +Send(LPDISPATCH pdispInterp, Tcl_Interp *interp, + int async, ClientData clientData, int objc, Tcl_Obj *CONST objv[]) +{ + VARIANT vCmd, vResult; + DISPPARAMS dp; + EXCEPINFO ei; + UINT uiErr = 0; + HRESULT hr = S_OK, ehr = S_OK; + Tcl_Obj *cmd = NULL; + DISPID dispid; + RegisteredInterp *riPtr = (RegisteredInterp *)clientData; + + cmd = Tcl_ConcatObj(objc, objv); + + /* + * Setup the arguments for the COM method call. + */ + + VariantInit(&vCmd); + VariantInit(&vResult); + memset(&dp, 0, sizeof(dp)); + memset(&ei, 0, sizeof(ei)); + + vCmd.vt = VT_BSTR; + vCmd.bstrVal = SysAllocString(Tcl_GetUnicode(cmd)); + + dp.cArgs = 1; + dp.rgvarg = &vCmd; + + /* + * Select the method to use based upon the async flag and + * call the method. + */ + + dispid = async ? TKWINSENDCOM_DISPID_ASYNC : TKWINSENDCOM_DISPID_SEND; + + hr = pdispInterp->lpVtbl->Invoke(pdispInterp, dispid, + &IID_NULL, LOCALE_SYSTEM_DEFAULT, DISPATCH_METHOD, + &dp, &vResult, &ei, &uiErr); + + /* + * Convert the result into a string and place in the interps result. + */ + + ehr = VariantChangeType(&vResult, &vResult, 0, VT_BSTR); + if (SUCCEEDED(ehr)) + Tcl_SetObjResult(interp, Tcl_NewUnicodeObj(vResult.bstrVal, -1)); + + /* + * Errors are returned as dispatch exceptions. If an error code was + * returned then we decode the exception and setup the Tcl + * error variables. + */ + + if (hr == DISP_E_EXCEPTION) + { + Tcl_Obj *opError, *opErrorCode, *opErrorInfo; + + if (ei.bstrSource != NULL) + { + int len; + char * szErrorInfo; + + opError = Tcl_NewUnicodeObj(ei.bstrSource, -1); + Tcl_ListObjIndex(interp, opError, 0, &opErrorCode); + Tcl_SetObjErrorCode(interp, opErrorCode); + + Tcl_ListObjIndex(interp, opError, 1, &opErrorInfo); + szErrorInfo = Tcl_GetStringFromObj(opErrorInfo, &len); + Tcl_AddObjErrorInfo(interp, szErrorInfo, len); + } + } + + /* + * Clean up any COM allocated resources. + */ + + SysFreeString(ei.bstrDescription); + SysFreeString(ei.bstrSource); + SysFreeString(ei.bstrHelpFile); + VariantClear(&vCmd); + + return (SUCCEEDED(hr) ? TCL_OK : TCL_ERROR); +} + +/* + * ---------------------------------------------------------------------- + * + * Win32ErrorObj -- + * + * Returns a string object containing text from a COM or + * Win32 error code + * + * Results: + * A Tcl_Obj containing the Win32 error message. + * + * Side effects: + * Removed the error message from the COM threads error object. + * + * ---------------------------------------------------------------------- + */ + +static Tcl_Obj* +Win32ErrorObj(HRESULT hrError) +{ + LPTSTR lpBuffer = NULL, p = NULL; + TCHAR sBuffer[30]; + Tcl_Obj* errPtr = NULL; + + FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER | FORMAT_MESSAGE_FROM_SYSTEM, + NULL, hrError, LANG_NEUTRAL, (LPTSTR)&lpBuffer, 0, NULL); + + if (lpBuffer == NULL) { + lpBuffer = sBuffer; + wsprintf(sBuffer, _T("Error Code: %08lX"), hrError); + } + + if ((p = _tcsrchr(lpBuffer, _T('\r'))) != NULL) + *p = _T('\0'); + +#ifdef _UNICODE + errPtr = Tcl_NewUnicodeObj(lpBuffer, wcslen(lpBuffer)); +#else + errPtr = Tcl_NewStringObj(lpBuffer, strlen(lpBuffer)); +#endif + + if (lpBuffer != sBuffer) + LocalFree((HLOCAL)lpBuffer); + + return errPtr; +} + +/* + * ---------------------------------------------------------------------- + * + * SetErrorInfo -- + * + * Convert the error information from a Tcl interpreter into a COM + * exception structure. This information is then registered with the + * COM thread exception object so that it can be used for rich error + * reporting by COM clients. + * + * Results: + * None. + * + * Side effects: + * The current COM thread has its error object modified. + * + * ---------------------------------------------------------------------- + */ + +void +SetExcepInfo(Tcl_Interp* interp, EXCEPINFO *pExcepInfo) +{ + if (pExcepInfo) + { + Tcl_Obj *opError, *opErrorInfo, *opErrorCode; + ICreateErrorInfo *pCEI; + IErrorInfo *pEI; + HRESULT hr; + + opError = Tcl_GetObjResult(interp); + opErrorInfo = Tcl_GetVar2Ex(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY); + opErrorCode = Tcl_GetVar2Ex(interp, "errorCode", NULL, TCL_GLOBAL_ONLY); + + Tcl_ListObjAppendElement(interp, opErrorCode, opErrorInfo); + + pExcepInfo->bstrDescription = SysAllocString(Tcl_GetUnicode(opError)); + pExcepInfo->bstrSource = SysAllocString(Tcl_GetUnicode(opErrorCode)); + pExcepInfo->scode = E_FAIL; + + hr = CreateErrorInfo(&pCEI); + if (SUCCEEDED(hr)) + { + hr = pCEI->lpVtbl->SetGUID(pCEI, &IID_IDispatch); + hr = pCEI->lpVtbl->SetDescription(pCEI, pExcepInfo->bstrDescription); + hr = pCEI->lpVtbl->SetSource(pCEI, pExcepInfo->bstrSource); + hr = pCEI->lpVtbl->QueryInterface(pCEI, &IID_IErrorInfo, (void**)&pEI); + if (SUCCEEDED(hr)) + { + SetErrorInfo(0, pEI); + pEI->lpVtbl->Release(pEI); + } + pCEI->lpVtbl->Release(pCEI); + } + } +} + +/* + * ---------------------------------------------------------------------- + * + * TkWinSend_QueueCommand -- + * + * Queue a script for asynchronous evaluation. This is called from + * the COM objects Async method. + * + * Results: + * None. + * + * Side effects: + * None. + * + * ---------------------------------------------------------------------- + */ + +int +TkWinSend_QueueCommand(Tcl_Interp *interp, Tcl_Obj *cmdPtr) +{ + SendEvent *evPtr; + + TRACE("SendQueueCommand()\n"); + + evPtr = (SendEvent *)ckalloc(sizeof(SendEvent)); + evPtr->header.proc = SendEventProc; + evPtr->header.nextPtr = NULL; + evPtr->interp = interp; + Tcl_Preserve(evPtr->interp); + + if (Tcl_IsShared(cmdPtr)) { + evPtr->cmdPtr = Tcl_DuplicateObj(cmdPtr); + } else { + evPtr->cmdPtr = cmdPtr; + Tcl_IncrRefCount(evPtr->cmdPtr); + } + + Tcl_QueueEvent((Tcl_Event *)evPtr, TCL_QUEUE_TAIL); + + return 0; +} + +/* + * ---------------------------------------------------------------------- + * + * SendEventProc -- + * + * Handle a request for an asynchronous send. Nothing is returned + * to the caller so the result is discarded. + * + * Results: + * Returns 1 if the event was handled or 0 to indicate it has + * been deferred. + * + * Side effects: + * The target interpreter's result will be modified. + * + * ---------------------------------------------------------------------- + */ + +static int +SendEventProc(Tcl_Event *eventPtr, int flags) +{ + int r = TCL_OK; + SendEvent *evPtr = (SendEvent *)eventPtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + TRACE("SendEventProc\n"); + + r = Tcl_EvalObjEx(evPtr->interp, evPtr->cmdPtr, + TCL_EVAL_DIRECT | TCL_EVAL_GLOBAL); + + Tcl_DecrRefCount(evPtr->cmdPtr); + Tcl_Release(evPtr->interp); + + return 1; /* 1 to indicate the event has been handled */ +} + +/* + * ---------------------------------------------------------------------- + * + * SendTrace -- + * + * Provide trace information to the Windows debug stream. + * To use this - use the TRACE macro, which compiles to nothing + * when DEBUG is not defined. + * + * Results: + * None. + * + * Side effects: + * None. + * + * ---------------------------------------------------------------------- + */ + +static void +SendTrace(const char *format, ...) +{ + va_list args; + static char buffer[1024]; + va_start (args, format); + _vsnprintf(buffer, 1023, format, args); + OutputDebugString(buffer); + va_end(args); } + +/* + * Local variables: + * mode: c + * tab-width: 8 + * c-indentation-style: tcltk + * End: + */ |