diff options
Diffstat (limited to 'win/tkWinSend.c')
| -rw-r--r-- | win/tkWinSend.c | 663 |
1 files changed, 367 insertions, 296 deletions
diff --git a/win/tkWinSend.c b/win/tkWinSend.c index 51d947e..2269512 100644 --- a/win/tkWinSend.c +++ b/win/tkWinSend.c @@ -1,114 +1,120 @@ -/* +/* * 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. * - * RCS: @(#) $Id: tkWinSend.c,v 1.10 2005/10/14 11:59:19 patthoyts Exp $ + * RCS: @(#) $Id: tkWinSend.c,v 1.11 2005/12/02 00:19:04 dkf Exp $ */ #include "tkWinSendCom.h" -/* Should be defined in WTypes.h but mingw 1.0 is missing them */ +/* + * 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 +#define ROTFLAGS_REGISTRATIONKEEPSALIVE 0x01 +#define ROTFLAGS_ALLOWANYCLIENT 0x02 #endif /* ! _ROTFLAGS_DEFINED */ -#define TKWINSEND_CLASS_NAME "TclEval" -#define TKWINSEND_REGISTRATION_BASE L"TclEval" +#define TKWINSEND_CLASS_NAME "TclEval" +#define TKWINSEND_REGISTRATION_BASE L"TclEval" #define MK_E_MONIKERALREADYREGISTERED \ - MAKE_HRESULT(SEVERITY_ERROR, FACILITY_ITF, 0x02A1) + 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. + * 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 */ + 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 */ + Tcl_Command token; /* Winsend command token */ } RegisteredInterp; typedef struct SendEvent { - Tcl_Event header; - Tcl_Interp *interp; - Tcl_Obj *cmdPtr; + Tcl_Event header; + Tcl_Interp *interp; + Tcl_Obj *cmdPtr; } SendEvent; typedef struct { - int initialized; + 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; +/* + * Functions internal to this file. + */ +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. + * 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. */ +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. */ { ThreadSpecificData *tsdPtr = NULL; TkWindow *winPtr = (TkWindow *)tkwin; @@ -118,59 +124,61 @@ Tk_SetAppName(tkwin, name) interp = winPtr->mainPtr->interp; +#ifndef TK_SEND_ENABLED_ON_WINDOWS /* * Temporarily disabled for bug #858822 */ + return name; +#else /* TK_SEND_ENABLED_ON_WINDOWS */ tsdPtr = (ThreadSpecificData *) - Tcl_GetThreadData(&dataKey, sizeof(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); + 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. + + /* + * 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); - + + 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); + RevokeObjectRegistration(riPtr); } - + RegisterInterp(name, riPtr); - return (CONST char *)riPtr->name; + return (CONST char *) riPtr->name; +#endif /* TK_SEND_ENABLED_ON_WINDOWS */ } /* @@ -178,15 +186,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. @@ -195,49 +202,56 @@ 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. */ { LPRUNNINGOBJECTTABLE pROT = NULL; LPCOLESTR oleszStub = TKWINSEND_REGISTRATION_BASE; HRESULT hr = S_OK; Tcl_Obj *objList = NULL; int result = TCL_OK; - + +#ifndef TK_SEND_ENABLED_ON_WINDOWS /* * Temporarily disabled for bug #858822 */ + return TCL_OK; +#else /* TK_SEND_ENABLED_ON_WINDOWS */ hr = GetRunningObjectTable(0, &pROT); - if(SUCCEEDED(hr)) { + 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)) { + if (SUCCEEDED(hr)) { IMoniker* pmk = NULL; - while (pEnum->lpVtbl->Next(pEnum, 1, &pmk, (ULONG*)NULL) - == S_OK) { + + while (pEnum->lpVtbl->Next(pEnum, 1, &pmk, NULL) == S_OK) { LPOLESTR olestr; - hr = pmk->lpVtbl->GetDisplayName(pmk, pBindCtx, - NULL, &olestr); + + hr = pmk->lpVtbl->GetDisplayName(pmk, pBindCtx, NULL, + &olestr); if (SUCCEEDED(hr)) { IMalloc *pMalloc = NULL; - - if (wcsncmp(olestr, oleszStub, wcslen(oleszStub)) == 0) { + + if (wcsncmp(olestr, oleszStub, + wcslen(oleszStub)) == 0) { LPOLESTR p = olestr + wcslen(oleszStub); + if (*p) { - result = Tcl_ListObjAppendElement(interp, - objList, Tcl_NewUnicodeObj(p + 1, -1)); + result = Tcl_ListObjAppendElement(interp, + objList, Tcl_NewUnicodeObj(p + 1, -1)); } } - + hr = CoGetMalloc(1, &pMalloc); if (SUCCEEDED(hr)) { pMalloc->lpVtbl->Free(pMalloc, (void*)olestr); @@ -254,19 +268,23 @@ TkGetInterpNames(interp, tkwin) } if (FAILED(hr)) { - /* expire the list if set */ - if (objList != NULL) { - Tcl_DecrRefCount(objList); - } - Tcl_SetObjResult(interp, Win32ErrorObj(hr)); - result = TCL_ERROR; + /* + * 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); + Tcl_SetObjResult(interp, objList); } - + return result; +#endif /* TK_SEND_ENABLED_ON_WINDOWS */ } /* @@ -274,8 +292,8 @@ TkGetInterpNames(interp, tkwin) * * Tk_SendCmd -- * - * This procedure is invoked to process the "send" Tcl command. - * See the user documentation for details on what it does. + * 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. @@ -287,24 +305,27 @@ TkGetInterpNames(interp, tkwin) */ 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. */ +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", "--", (CONST char *)NULL + "-async", "-displayof", "--", NULL }; int result = TCL_OK; int i, optind, async = 0; Tcl_Obj *displayPtr = NULL; - /* process the command options */ + /* + * Process the command options. + */ + for (i = 1; i < objc; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], sendOptions, "option", 0, &optind) != TCL_OK) { @@ -319,12 +340,15 @@ Tk_SendObjCmd(clientData, interp, objc, objv) break; } } - - /* ensure we still have a valid command */ + + /* + * Ensure we still have a valid command. + */ + if ((objc - i) < 2) { - Tcl_WrongNumArgs(interp, 1, objv, + Tcl_WrongNumArgs(interp, 1, objv, "?-async? ?-displayof? ?--? interpName arg ?arg ...?"); - result = TCL_ERROR; + result = TCL_ERROR; } /* @@ -333,24 +357,25 @@ Tk_SendObjCmd(clientData, interp, objc, objv) if (displayPtr) { Tcl_SetStringObj(Tcl_GetObjResult(interp), - "option not implemented: \"displayof\" is not available " - "for this platform.", -1); + "option not implemented: \"displayof\" is not available " + "for this platform.", -1); result = TCL_ERROR; } - - /* send the arguments to the foreign interp */ + + /* + * 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]); + result = Send(pdisp, interp, async, clientData, objc-i, objv+i); pdisp->lpVtbl->Release(pdisp); } } - + return result; } @@ -359,16 +384,14 @@ Tk_SendObjCmd(clientData, interp, objc, objv) * * 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. + * 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. + * 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. @@ -377,19 +400,26 @@ Tk_SendObjCmd(clientData, interp, objc, objv) */ static int -FindInterpreterObject(Tcl_Interp *interp, CONST char *name, LPDISPATCH *ppdisp) +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); @@ -401,10 +431,10 @@ FindInterpreterObject(Tcl_Interp *interp, CONST char *name, LPDISPATCH *ppdisp) } else { Tcl_ResetResult(interp); Tcl_AppendResult(interp, - "no application named \"", name, "\"", NULL); + "no application named \"", name, "\"", NULL); result = TCL_ERROR; } - + pmk->lpVtbl->Release(pmk); } pBindCtx->lpVtbl->Release(pBindCtx); @@ -423,38 +453,50 @@ FindInterpreterObject(Tcl_Interp *interp, CONST char *name, LPDISPATCH *ppdisp) * * CmdDeleteProc -- * - * This procedure is invoked by Tcl when the "send" command - * is deleted in an interpreter. It unregisters the interpreter. + * 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. + * 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) +CmdDeleteProc( + ClientData clientData) { RegisteredInterp *riPtr = (RegisteredInterp *)clientData; - /* Lock the package structure in memory */ + /* + * Lock the package structure in memory. + */ + Tcl_Preserve(clientData); - /* Revoke the ROT registration */ + /* + * Revoke the ROT registration. + */ + RevokeObjectRegistration(riPtr); - /* Release the registration object */ + /* + * Release the registration object. + */ + riPtr->obj->lpVtbl->Release(riPtr->obj); riPtr->obj = NULL; Tcl_DeleteAssocData(riPtr->interp, "tkWinSend::ri"); - /* unlock the package data structure. */ + /* + * Unlock the package data structure. + */ + Tcl_Release(clientData); ckfree(clientData); @@ -465,37 +507,42 @@ CmdDeleteProc(ClientData clientData) * * RevokeObjectRegistration -- * - * Releases the interpreters registration object from the - * Running Object Table. + * 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. + * The stored cookie value is zeroed and the name is free'd and the + * pointer set to NULL. * *-------------------------------------------------------------- */ static void -RevokeObjectRegistration(RegisteredInterp *riPtr) +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; - } + 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 */ + /* + * Release the name storage. + */ + if (riPtr->name != NULL) { free(riPtr->name); - riPtr->name = NULL; + riPtr->name = NULL; } } @@ -504,8 +551,8 @@ RevokeObjectRegistration(RegisteredInterp *riPtr) * * InterpDeleteProc -- * - * This is called when the interpreter is deleted and used to - * unregister the COM libraries. + * This is called when the interpreter is deleted and used to unregister + * the COM libraries. * * Results: * None. @@ -517,7 +564,9 @@ RevokeObjectRegistration(RegisteredInterp *riPtr) */ static void -InterpDeleteProc(ClientData clientData, Tcl_Interp *interp) +InterpDeleteProc( + ClientData clientData, + Tcl_Interp *interp) { CoUninitialize(); } @@ -526,13 +575,13 @@ InterpDeleteProc(ClientData clientData, Tcl_Interp *interp) * ---------------------------------------------------------------------- * * 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. + * 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. @@ -541,23 +590,26 @@ InterpDeleteProc(ClientData clientData, Tcl_Interp *interp) */ static HRESULT -BuildMoniker(CONST char *name, LPMONIKER *ppmk) +BuildMoniker( + CONST char *name, + LPMONIKER *ppmk) { LPMONIKER pmkClass = NULL; HRESULT hr = CreateFileMoniker(TKWINSEND_REGISTRATION_BASE, &pmkClass); + if (SUCCEEDED(hr)) { - LPMONIKER pmkItem = NULL; + LPMONIKER pmkItem = NULL; Tcl_DString dString; Tcl_DStringInit(&dString); Tcl_UtfToUniCharDString(name, -1, &dString); - hr = CreateFileMoniker((LPOLESTR)Tcl_DStringValue(&dString), &pmkItem); + hr = CreateFileMoniker((LPOLESTR)Tcl_DStringValue(&dString), &pmkItem); Tcl_DStringFree(&dString); - if (SUCCEEDED(hr)) { - hr = pmkClass->lpVtbl->ComposeWith(pmkClass, pmkItem, FALSE, ppmk); + if (SUCCEEDED(hr)) { + hr = pmkClass->lpVtbl->ComposeWith(pmkClass, pmkItem, FALSE, ppmk); pmkItem->lpVtbl->Release(pmkItem); - } - pmkClass->lpVtbl->Release(pmkClass); + } + pmkClass->lpVtbl->Release(pmkClass); } return hr; } @@ -566,23 +618,25 @@ BuildMoniker(CONST char *name, LPMONIKER *ppmk) * ---------------------------------------------------------------------- * * 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. - * + * + * 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. + * Registration returns a cookie value which is stored. We also store a + * copy of the name. * * ---------------------------------------------------------------------- */ static HRESULT -RegisterInterp(CONST char *name, RegisteredInterp *riPtr) +RegisterInterp( + CONST char *name, + RegisteredInterp *riPtr) { HRESULT hr = S_OK; LPRUNNINGOBJECTTABLE pROT = NULL; @@ -594,9 +648,7 @@ RegisterInterp(CONST char *name, RegisteredInterp *riPtr) hr = GetRunningObjectTable(0, &pROT); if (SUCCEEDED(hr)) { - offset = 0; - for (i = 1; SUCCEEDED(hr); i++) { if (i > 1) { if (i == 2) { @@ -609,11 +661,11 @@ RegisterInterp(CONST char *name, RegisteredInterp *riPtr) } sprintf(Tcl_DStringValue(&dString) + offset, "%d", i); } - + hr = BuildMoniker(actualName, &pmk); if (SUCCEEDED(hr)) { - hr = pROT->lpVtbl->Register(pROT, + hr = pROT->lpVtbl->Register(pROT, ROTFLAGS_REGISTRATIONKEEPSALIVE, riPtr->obj, pmk, &riPtr->cookie); @@ -621,17 +673,17 @@ RegisterInterp(CONST char *name, RegisteredInterp *riPtr) } if (hr == MK_S_MONIKERALREADYREGISTERED) { - pROT->lpVtbl->Revoke(pROT, riPtr->cookie); + pROT->lpVtbl->Revoke(pROT, riPtr->cookie); } else if (hr == S_OK) { break; } } - + pROT->lpVtbl->Release(pROT); } if (SUCCEEDED(hr)) { - riPtr->name = strdup(actualName); + riPtr->name = strdup(actualName); } Tcl_DStringFree(&dString); @@ -643,9 +695,9 @@ RegisterInterp(CONST char *name, RegisteredInterp *riPtr) * * 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. + * 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. @@ -654,15 +706,18 @@ RegisterInterp(CONST char *name, RegisteredInterp *riPtr) * 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 */ +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; @@ -690,8 +745,7 @@ Send(LPDISPATCH pdispInterp, /* pointer to the remote interp's COM object */ dp.rgvarg = &vCmd; /* - * Select the method to use based upon the async flag and - * call the method. + * Select the method to use based upon the async flag and call the method. */ dispid = async ? TKWINSENDCOM_DISPID_ASYNC : TKWINSENDCOM_DISPID_SEND; @@ -703,36 +757,36 @@ Send(LPDISPATCH pdispInterp, /* pointer to the remote interp's COM object */ /* * 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)); + 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. + * 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); - } + 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. */ @@ -749,8 +803,7 @@ Send(LPDISPATCH pdispInterp, /* pointer to the remote interp's COM object */ * * Win32ErrorObj -- * - * Returns a string object containing text from a COM or - * Win32 error code + * Returns a string object containing text from a COM or Win32 error code * * Results: * A Tcl_Obj containing the Win32 error message. @@ -762,7 +815,8 @@ Send(LPDISPATCH pdispInterp, /* pointer to the remote interp's COM object */ */ static Tcl_Obj* -Win32ErrorObj(HRESULT hrError) +Win32ErrorObj( + HRESULT hrError) { LPTSTR lpBuffer = NULL, p = NULL; TCHAR sBuffer[30]; @@ -778,7 +832,7 @@ Win32ErrorObj(HRESULT hrError) } if ((p = _tcsrchr(lpBuffer, _T('\r'))) != NULL) { - *p = _T('\0'); + *p = _T('\0'); } #ifdef _UNICODE @@ -788,7 +842,7 @@ Win32ErrorObj(HRESULT hrError) #endif if (lpBuffer != sBuffer) { - LocalFree((HLOCAL)lpBuffer); + LocalFree((HLOCAL)lpBuffer); } return errPtr; @@ -800,8 +854,8 @@ Win32ErrorObj(HRESULT hrError) * 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 + * 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: @@ -814,43 +868,47 @@ Win32ErrorObj(HRESULT hrError) */ void -SetExcepInfo(Tcl_Interp* interp, EXCEPINFO *pExcepInfo) +SetExcepInfo( + Tcl_Interp* interp, + EXCEPINFO *pExcepInfo) { if (pExcepInfo) { - Tcl_Obj *opError, *opErrorInfo, *opErrorCode; - ICreateErrorInfo *pCEI; - IErrorInfo *pEI; - HRESULT hr; + 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); + 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); - } + 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); + } } } @@ -859,8 +917,8 @@ SetExcepInfo(Tcl_Interp* interp, EXCEPINFO *pExcepInfo) * * TkWinSend_QueueCommand -- * - * Queue a script for asynchronous evaluation. This is called from - * the COM objects Async method. + * Queue a script for asynchronous evaluation. This is called from the + * COM objects Async method. * * Results: * None. @@ -871,8 +929,10 @@ SetExcepInfo(Tcl_Interp* interp, EXCEPINFO *pExcepInfo) * ---------------------------------------------------------------------- */ -int -TkWinSend_QueueCommand(Tcl_Interp *interp, Tcl_Obj *cmdPtr) +int +TkWinSend_QueueCommand( + Tcl_Interp *interp, + Tcl_Obj *cmdPtr) { SendEvent *evPtr; @@ -885,10 +945,10 @@ TkWinSend_QueueCommand(Tcl_Interp *interp, Tcl_Obj *cmdPtr) Tcl_Preserve(evPtr->interp); if (Tcl_IsShared(cmdPtr)) { - evPtr->cmdPtr = Tcl_DuplicateObj(cmdPtr); + evPtr->cmdPtr = Tcl_DuplicateObj(cmdPtr); } else { - evPtr->cmdPtr = cmdPtr; - Tcl_IncrRefCount(evPtr->cmdPtr); + evPtr->cmdPtr = cmdPtr; + Tcl_IncrRefCount(evPtr->cmdPtr); } Tcl_QueueEvent((Tcl_Event *)evPtr, TCL_QUEUE_TAIL); @@ -901,12 +961,12 @@ TkWinSend_QueueCommand(Tcl_Interp *interp, Tcl_Obj *cmdPtr) * * SendEventProc -- * - * Handle a request for an asynchronous send. Nothing is returned - * to the caller so the result is discarded. + * 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. + * 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. @@ -915,16 +975,18 @@ TkWinSend_QueueCommand(Tcl_Interp *interp, Tcl_Obj *cmdPtr) */ static int -SendEventProc(Tcl_Event *eventPtr, int flags) +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_EVAL_DIRECT | TCL_EVAL_GLOBAL); + Tcl_DecrRefCount(evPtr->cmdPtr); Tcl_Release(evPtr->interp); @@ -936,9 +998,9 @@ SendEventProc(Tcl_Event *eventPtr, int flags) * * 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. + * 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. @@ -950,13 +1012,22 @@ SendEventProc(Tcl_Event *eventPtr, int flags) */ static void -SendTrace(const char *format, ...) +SendTrace( + const char *format, ...) { - va_list args; + va_list args; static char buffer[1024]; - va_start (args, format); + + 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: + */ |