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