diff options
| -rw-r--r-- | ChangeLog | 7 | ||||
| -rw-r--r-- | win/makefile.vc | 5 | ||||
| -rw-r--r-- | win/tkWinSend.c | 874 | ||||
| -rw-r--r-- | win/tkWinSendCom.c | 431 | ||||
| -rw-r--r-- | win/tkWinSendCom.h | 58 |
5 files changed, 1370 insertions, 5 deletions
@@ -1,3 +1,10 @@ +2003-09-27 Pat Thoyts <patthoyts@users.sourceforge.net> + + * win/makefile.vc: Implementation of TIP #150, "Provide + * win/tkWinSend.c: 'send' command for Windows" + * win/tkWinSendCom.h: + * win/tkWinSendCom.c: + 2003-09-26 Benjamin Riefenstahl <Benjamin.Riefenstahl@epost.de> * macosx/tkMacOSXWm.c (TkWmStackorderToplevelWrapperMap): Add diff --git a/win/makefile.vc b/win/makefile.vc index c8927e8..73e52fa 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -12,7 +12,7 @@ # Copyright (c) 2001-2002 David Gravereaux. # #------------------------------------------------------------------------------ -# RCS: @(#) $Id: makefile.vc,v 1.72 2003/08/25 20:35:59 davygrvy Exp $ +# RCS: @(#) $Id: makefile.vc,v 1.73 2003/09/26 23:59:26 patthoyts Exp $ #------------------------------------------------------------------------------ !if "$(MSVCDIR)" == "" @@ -241,6 +241,7 @@ TKOBJS = \ $(TMP_DIR)\tkWinRegion.obj \ $(TMP_DIR)\tkWinScrlbr.obj \ $(TMP_DIR)\tkWinSend.obj \ + $(TMP_DIR)\tkWinSendCom.obj \ $(TMP_DIR)\tkWinWindow.obj \ $(TMP_DIR)\tkWinWm.obj \ $(TMP_DIR)\tkWinX.obj \ @@ -425,7 +426,7 @@ dlllflags = $(lflags) -dll conlflags = $(lflags) -subsystem:console guilflags = $(lflags) -subsystem:windows -baselibs = kernel32.lib advapi32.lib user32.lib +baselibs = kernel32.lib advapi32.lib user32.lib ole32.lib oleaut32.lib uuid.lib guilibs = $(baselibs) shell32.lib gdi32.lib comdlg32.lib winspool.lib imm32.lib comctl32.lib 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: + */ diff --git a/win/tkWinSendCom.c b/win/tkWinSendCom.c new file mode 100644 index 0000000..325f127 --- /dev/null +++ b/win/tkWinSendCom.c @@ -0,0 +1,431 @@ +/* + * tkWinSend.c -- + * + * This file provides procedures that implement the Windows "send" + * command, allowing commands to be passed from interpreter + * to interpreter. + * + * We implement a COM class for use in registering Tcl interpreters + * with the system's Running Object Table. + * This class implements an IDispatch interface with the following method: + * Send(String cmd) As String + * In other words the Send methods takes a string and evaluates this in + * the Tcl interpreter. The result is returned as another string. + * + * Copyright (C) 2002 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: tkWinSendCom.c,v 1.1 2003/09/26 23:59:26 patthoyts Exp $ + */ + +#include "tkWinSendCom.h" + +/* + * ---------------------------------------------------------------------- + * Non-public prototypes. + * + * These are the interface methods for IUnknown, IDispatch and + * ISupportErrorInfo. + * + * ---------------------------------------------------------------------- + */ + +static void TkWinSendCom_Destroy(LPDISPATCH pdisp); + +static STDMETHODIMP WinSendCom_QueryInterface(IDispatch *This, + REFIID riid, void **ppvObject); +static STDMETHODIMP_(ULONG) WinSendCom_AddRef(IDispatch *This); +static STDMETHODIMP_(ULONG) WinSendCom_Release(IDispatch *This); +static STDMETHODIMP WinSendCom_GetTypeInfoCount(IDispatch *This, + UINT *pctinfo); +static STDMETHODIMP WinSendCom_GetTypeInfo(IDispatch *This, UINT iTInfo, + LCID lcid, ITypeInfo **ppTI); +static STDMETHODIMP WinSendCom_GetIDsOfNames(IDispatch *This, REFIID riid, + LPOLESTR *rgszNames, + UINT cNames, LCID lcid, + DISPID *rgDispId); +static STDMETHODIMP WinSendCom_Invoke(IDispatch *This, DISPID dispidMember, + REFIID riid, LCID lcid, WORD wFlags, + DISPPARAMS *pDispParams, + VARIANT *pvarResult, + EXCEPINFO *pExcepInfo, + UINT *puArgErr); + +static STDMETHODIMP ISupportErrorInfo_QueryInterface(ISupportErrorInfo *This, + REFIID riid, void **ppvObject); +static STDMETHODIMP_(ULONG) ISupportErrorInfo_AddRef(ISupportErrorInfo *This); +static STDMETHODIMP_(ULONG) ISupportErrorInfo_Release(ISupportErrorInfo *This); +static STDMETHODIMP ISupportErrorInfo_InterfaceSupportsErrorInfo(ISupportErrorInfo *This, + REFIID riid); + +static HRESULT Send(TkWinSendCom* obj, VARIANT vCmd, VARIANT* pvResult, + EXCEPINFO* pExcepInfo, UINT *puArgErr); +static HRESULT Async(TkWinSendCom* obj, VARIANT Cmd, + EXCEPINFO *pExcepInfo, UINT *puArgErr); + +/* + * ---------------------------------------------------------------------- + * + * CreateInstance -- + * + * Create and initialises a new instance of the WinSend COM class and + * returns an interface pointer for you to use. + * + * ---------------------------------------------------------------------- + */ + +HRESULT +TkWinSendCom_CreateInstance(Tcl_Interp *interp, REFIID riid, void **ppv) +{ + /* construct v-tables for each interface */ + static IDispatchVtbl vtbl = { + WinSendCom_QueryInterface, + WinSendCom_AddRef, + WinSendCom_Release, + WinSendCom_GetTypeInfoCount, + WinSendCom_GetTypeInfo, + WinSendCom_GetIDsOfNames, + WinSendCom_Invoke, + }; + + static ISupportErrorInfoVtbl vtbl2 = { + ISupportErrorInfo_QueryInterface, + ISupportErrorInfo_AddRef, + ISupportErrorInfo_Release, + ISupportErrorInfo_InterfaceSupportsErrorInfo, + }; + + HRESULT hr = S_OK; + TkWinSendCom *obj = NULL; + + /* + * This had probably better always be globally visible memory so + * we shall use the COM Task allocator. + */ + + obj = (TkWinSendCom*)CoTaskMemAlloc(sizeof(TkWinSendCom)); + if (obj == NULL) { + *ppv = NULL; + hr = E_OUTOFMEMORY; + } else { + obj->lpVtbl = &vtbl; + obj->lpVtbl2 = &vtbl2; + obj->refcount = 0; + obj->interp = interp; + + /* lock the interp? Tcl_AddRef/Retain? */ + + hr = obj->lpVtbl->QueryInterface((IDispatch*)obj, riid, ppv); + } + + return hr; +} + +/* + * ---------------------------------------------------------------------- + * + * TkWinSendCom_Destroy -- + * + * This helper function is the destructor for our COM class. + * + * Results: + * None. + * + * Side effects: + * Releases the storage allocated for this object. + * + * ---------------------------------------------------------------------- + */ +static void +TkWinSendCom_Destroy(LPDISPATCH pdisp) +{ + CoTaskMemFree((void*)pdisp); +} + +/* + * ---------------------------------------------------------------------- + * + * IDispatch -- + * + * The IDispatch interface implements the 'late-binding' COM methods + * typically used by scripting COM clients. + * The Invoke method is the most important one. + * + * ---------------------------------------------------------------------- + */ + +static STDMETHODIMP +WinSendCom_QueryInterface(IDispatch *This, + REFIID riid, + void **ppvObject) +{ + HRESULT hr = E_NOINTERFACE; + TkWinSendCom *this = (TkWinSendCom*)This; + *ppvObject = NULL; + + if (memcmp(riid, &IID_IUnknown, sizeof(IID)) == 0 + || memcmp(riid, &IID_IDispatch, sizeof(IID)) == 0) { + *ppvObject = (void**)this; + this->lpVtbl->AddRef(This); + hr = S_OK; + } else if (memcmp(riid, &IID_ISupportErrorInfo, sizeof(IID)) == 0) { + *ppvObject = (void**)(this + 1); + this->lpVtbl2->AddRef((ISupportErrorInfo*)(this + 1)); + hr = S_OK; + } + return hr; +} + +static STDMETHODIMP_(ULONG) +WinSendCom_AddRef(IDispatch *This) +{ + TkWinSendCom *this = (TkWinSendCom*)This; + return InterlockedIncrement(&this->refcount); +} + +static STDMETHODIMP_(ULONG) +WinSendCom_Release(IDispatch *This) +{ + long r = 0; + TkWinSendCom *this = (TkWinSendCom*)This; + if ((r = InterlockedDecrement(&this->refcount)) == 0) { + TkWinSendCom_Destroy(This); + } + return r; +} + +static STDMETHODIMP +WinSendCom_GetTypeInfoCount(IDispatch *This, UINT *pctinfo) +{ + HRESULT hr = E_POINTER; + if (pctinfo != NULL) { + *pctinfo = 0; + hr = S_OK; + } + return hr; +} + +static STDMETHODIMP +WinSendCom_GetTypeInfo(IDispatch *This, UINT iTInfo, + LCID lcid, ITypeInfo **ppTI) +{ + HRESULT hr = E_POINTER; + if (ppTI) + { + *ppTI = NULL; + hr = E_NOTIMPL; + } + return hr; +} + +static STDMETHODIMP +WinSendCom_GetIDsOfNames(IDispatch *This, REFIID riid, + LPOLESTR *rgszNames, + UINT cNames, LCID lcid, + DISPID *rgDispId) +{ + HRESULT hr = E_POINTER; + if (rgDispId) + { + hr = DISP_E_UNKNOWNNAME; + if (_wcsicmp(*rgszNames, L"Send") == 0) + *rgDispId = TKWINSENDCOM_DISPID_SEND, hr = S_OK; + else if (_wcsicmp(*rgszNames, L"Async") == 0) + *rgDispId = TKWINSENDCOM_DISPID_ASYNC, hr = S_OK; + } + return hr; +} + +static STDMETHODIMP +WinSendCom_Invoke(IDispatch *This, DISPID dispidMember, + REFIID riid, LCID lcid, WORD wFlags, + DISPPARAMS *pDispParams, + VARIANT *pvarResult, + EXCEPINFO *pExcepInfo, + UINT *puArgErr) +{ + HRESULT hr = DISP_E_MEMBERNOTFOUND; + TkWinSendCom *this = (TkWinSendCom*)This; + + switch (dispidMember) + { + case TKWINSENDCOM_DISPID_SEND: + if (wFlags | DISPATCH_METHOD) + { + if (pDispParams->cArgs != 1) + hr = DISP_E_BADPARAMCOUNT; + else + hr = Send(this, pDispParams->rgvarg[0], + pvarResult, pExcepInfo, puArgErr); + } + break; + + case TKWINSENDCOM_DISPID_ASYNC: + if (wFlags | DISPATCH_METHOD) + { + if (pDispParams->cArgs != 1) + hr = DISP_E_BADPARAMCOUNT; + else + hr = Async(this, pDispParams->rgvarg[0], + pExcepInfo, puArgErr); + } + break; + + } + return hr; +} + +/* + * ---------------------------------------------------------------------- + * + * ISupportErrorInfo -- + * + * This interface provides rich error information to COM clients. + * Used by VB and scripting COM clients. + * + * ---------------------------------------------------------------------- + */ + +static STDMETHODIMP +ISupportErrorInfo_QueryInterface(ISupportErrorInfo *This, + REFIID riid, void **ppvObject) +{ + TkWinSendCom *this = (TkWinSendCom*)(This - 1); + return this->lpVtbl->QueryInterface((IDispatch*)this, riid, ppvObject); +} + +static STDMETHODIMP_(ULONG) +ISupportErrorInfo_AddRef(ISupportErrorInfo *This) +{ + TkWinSendCom *this = (TkWinSendCom*)(This - 1); + return InterlockedIncrement(&this->refcount); +} + +static STDMETHODIMP_(ULONG) +ISupportErrorInfo_Release(ISupportErrorInfo *This) +{ + TkWinSendCom *this = (TkWinSendCom*)(This - 1); + return this->lpVtbl->Release((IDispatch*)this); +} + +static STDMETHODIMP +ISupportErrorInfo_InterfaceSupportsErrorInfo(ISupportErrorInfo *This, + REFIID riid) +{ + TkWinSendCom *this = (TkWinSendCom*)(This - 1); + return S_OK; /* or S_FALSE */ +} + +/* + * ---------------------------------------------------------------------- + * + * Async -- + * + * Queues the command for evaluation in the assigned interpreter. + * + * Results: + * A standard COM HRESULT is returned. The Tcl result is discarded. + * + * Side effects: + * The interpreters state and result will be modified. + * + * ---------------------------------------------------------------------- + */ + +static HRESULT +Async(TkWinSendCom* obj, VARIANT Cmd, EXCEPINFO *pExcepInfo, UINT *puArgErr) +{ + HRESULT hr = S_OK; + int r = TCL_OK; + VARIANT vCmd; + + VariantInit(&vCmd); + + hr = VariantChangeType(&vCmd, &Cmd, 0, VT_BSTR); + if (FAILED(hr)) { + Tcl_SetStringObj(Tcl_GetObjResult(obj->interp), + "invalid args: Async(command)", -1); + SetExcepInfo(obj->interp, pExcepInfo); + hr = DISP_E_EXCEPTION; + } + + + if (SUCCEEDED(hr)) + { + if (obj->interp) + { + Tcl_Obj *scriptPtr = Tcl_NewUnicodeObj(vCmd.bstrVal, + SysStringLen(vCmd.bstrVal)); + r = TkWinSend_QueueCommand(obj->interp, scriptPtr); + } + } + + VariantClear(&vCmd); + + return hr; +} + +/* + * ---------------------------------------------------------------------- + * + * Send -- + * + * Evaluates the string in the assigned interpreter. If the result + * is a valid address then set it to the result returned by the + * evaluation. Tcl exceptions are converted into COM exceptions. + * + * Results: + * A standard COM HRESULT is returned. The Tcl result is set as + * the method calls result. + * + * Side effects: + * The interpreters state and result will be modified. + * + * ---------------------------------------------------------------------- + */ + +static HRESULT +Send(TkWinSendCom* obj, VARIANT vCmd, + VARIANT* pvResult, EXCEPINFO* pExcepInfo, UINT *puArgErr) +{ + HRESULT hr = S_OK; + int r = TCL_OK; + VARIANT v; + + VariantInit(&v); + hr = VariantChangeType(&v, &vCmd, 0, VT_BSTR); + if (SUCCEEDED(hr)) + { + if (obj->interp) + { + Tcl_Obj *scriptPtr = Tcl_NewUnicodeObj(v.bstrVal, + SysStringLen(v.bstrVal)); + + r = Tcl_EvalObjEx(obj->interp, scriptPtr, + TCL_EVAL_DIRECT | TCL_EVAL_GLOBAL); + if (pvResult) + { + VariantInit(pvResult); + pvResult->vt = VT_BSTR; + pvResult->bstrVal = SysAllocString(Tcl_GetUnicode(Tcl_GetObjResult(obj->interp))); + } + if (r == TCL_ERROR) + { + hr = DISP_E_EXCEPTION; + SetExcepInfo(obj->interp, pExcepInfo); + } + } + VariantClear(&v); + } + return hr; +} + +/* + * Local Variables: + * mode: c + * tab-width: 8 + * c-indentation-style: tcltk + * End: + */ diff --git a/win/tkWinSendCom.h b/win/tkWinSendCom.h new file mode 100644 index 0000000..fd98ca2 --- /dev/null +++ b/win/tkWinSendCom.h @@ -0,0 +1,58 @@ +/* + * tkWinSendCom.h -- + * + * This file provides procedures that implement the Windows "send" + * command, allowing commands to be passed from interpreter + * to interpreter. + * + * Copyright (C) 2002 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: tkWinSendCom.h,v 1.1 2003/09/26 23:59:26 patthoyts Exp $ + */ + +#ifndef _tkWinSendCom_h_INCLUDE +#define _tkWinSendCom_h_INCLUDE + +#include "tkPort.h" +#include "tkInt.h" + +#include <ole2.h> + +/* + * TkWinSendCom CoClass structure + */ + +typedef struct { + IDispatchVtbl *lpVtbl; + ISupportErrorInfoVtbl *lpVtbl2; + long refcount; + Tcl_Interp *interp; +} TkWinSendCom; + +/* + * TkWinSendCom Dispatch IDs + */ + +#define TKWINSENDCOM_DISPID_SEND 1 +#define TKWINSENDCOM_DISPID_ASYNC 2 + +/* + * TkWinSendCom public functions + */ + +HRESULT TkWinSendCom_CreateInstance(Tcl_Interp *interp, + REFIID riid, void **ppv); +int TkWinSend_QueueCommand(Tcl_Interp *interp, Tcl_Obj *cmdPtr); +void SetExcepInfo(Tcl_Interp* interp, EXCEPINFO *pExcepInfo); + +#endif /* _tkWinSendCom_h_INCLUDE */ + +/* + * Local Variables: + * mode: c + * indent-tabs-mode: nil + * End: + */ |