summaryrefslogtreecommitdiffstats
path: root/win/tkWinSend.c
diff options
context:
space:
mode:
Diffstat (limited to 'win/tkWinSend.c')
-rw-r--r--win/tkWinSend.c663
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:
+ */