1/*
2 * tkWinSend.c --
3 *
4 *	This file provides functions that implement the "send" command,
5 *	allowing commands to be passed from interpreter to interpreter.
6 *
7 * Copyright (c) 1997 by Sun Microsystems, Inc.
8 * Copyright (c) 2003 Pat Thoyts <patthoyts@users.sourceforge.net>
9 *
10 * See the file "license.terms" for information on usage and redistribution of
11 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
12 *
13 * RCS: @(#) $Id$
14 */
15
16#include "tkInt.h"
17#include "tkWinSendCom.h"
18
19#ifdef _MSC_VER
20#define vsnprintf _vsnprintf
21#endif
22
23/*
24 * Should be defined in WTypes.h but mingw 1.0 is missing them.
25 */
26
27#ifndef _ROTFLAGS_DEFINED
28#define _ROTFLAGS_DEFINED
29#define ROTFLAGS_REGISTRATIONKEEPSALIVE 0x01
30#define ROTFLAGS_ALLOWANYCLIENT		0x02
31#endif /* ! _ROTFLAGS_DEFINED */
32
33#define TKWINSEND_CLASS_NAME		"TclEval"
34#define TKWINSEND_REGISTRATION_BASE	L"TclEval"
35
36#define MK_E_MONIKERALREADYREGISTERED \
37	MAKE_HRESULT(SEVERITY_ERROR, FACILITY_ITF, 0x02A1)
38
39/*
40 * Package information structure. This is used to keep interpreter specific
41 * details for use when releasing the package resources upon interpreter
42 * deletion or package removal.
43 */
44
45typedef struct {
46    char *name;			/* The registered application name */
47    DWORD cookie;		/* ROT cookie returned on registration */
48    LPUNKNOWN obj;		/* Interface for the registration object */
49    Tcl_Interp *interp;
50    Tcl_Command token;		/* Winsend command token */
51} RegisteredInterp;
52
53typedef struct SendEvent {
54    Tcl_Event header;
55    Tcl_Interp *interp;
56    Tcl_Obj *cmdPtr;
57} SendEvent;
58
59#ifdef TK_SEND_ENABLED_ON_WINDOWS
60typedef struct {
61    int initialized;
62} ThreadSpecificData;
63static Tcl_ThreadDataKey dataKey;
64#endif
65
66/*
67 * Functions internal to this file.
68 */
69
70#ifdef TK_SEND_ENABLED_ON_WINDOWS
71static void		CmdDeleteProc(ClientData clientData);
72static void		InterpDeleteProc(ClientData clientData,
73			    Tcl_Interp *interp);
74static void		RevokeObjectRegistration(RegisteredInterp *riPtr);
75#endif
76static HRESULT		BuildMoniker(const char *name, LPMONIKER *pmk);
77#ifdef TK_SEND_ENABLED_ON_WINDOWS
78static HRESULT		RegisterInterp(const char *name,
79			    RegisteredInterp *riPtr);
80#endif
81static int		FindInterpreterObject(Tcl_Interp *interp,
82			    const char *name, LPDISPATCH *ppdisp);
83static int		Send(LPDISPATCH pdispInterp, Tcl_Interp *interp,
84			    int async, ClientData clientData, int objc,
85			    Tcl_Obj *const objv[]);
86static Tcl_Obj *	Win32ErrorObj(HRESULT hrError);
87static void		SendTrace(const char *format, ...);
88static Tcl_EventProc	SendEventProc;
89
90#if defined(DEBUG) || defined(_DEBUG)
91#define TRACE SendTrace
92#else
93#define TRACE 1 ? ((void)0) : SendTrace
94#endif
95
96/*
97 *--------------------------------------------------------------
98 *
99 * Tk_SetAppName --
100 *
101 *	This function is called to associate an ASCII name with a Tk
102 *	application. If the application has already been named, the name
103 *	replaces the old one.
104 *
105 * Results:
106 *	The return value is the name actually given to the application. This
107 *	will normally be the same as name, but if name was already in use for
108 *	an application then a name of the form "name #2" will be chosen, with
109 *	a high enough number to make the name unique.
110 *
111 * Side effects:
112 *	Registration info is saved, thereby allowing the "send" command to be
113 *	used later to invoke commands in the application. In addition, the
114 *	"send" command is created in the application's interpreter. The
115 *	registration will be removed automatically if the interpreter is
116 *	deleted or the "send" command is removed.
117 *
118 *--------------------------------------------------------------
119 */
120
121const char *
122Tk_SetAppName(
123    Tk_Window tkwin,		/* Token for any window in the application to
124				 * be named: it is just used to identify the
125				 * application and the display.  */
126    const char *name)		/* The name that will be used to refer to the
127				 * interpreter in later "send" commands. Must
128				 * be globally unique. */
129{
130#ifndef TK_SEND_ENABLED_ON_WINDOWS
131    /*
132     * Temporarily disabled for bug #858822
133     */
134
135    return name;
136#else /* TK_SEND_ENABLED_ON_WINDOWS */
137
138    ThreadSpecificData *tsdPtr = NULL;
139    TkWindow *winPtr = (TkWindow *) tkwin;
140    RegisteredInterp *riPtr = NULL;
141    Tcl_Interp *interp;
142    HRESULT hr = S_OK;
143
144    interp = winPtr->mainPtr->interp;
145
146    tsdPtr = (ThreadSpecificData *)
147	    Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
148
149    /*
150     * Initialise the COM library for this interpreter just once.
151     */
152
153    if (tsdPtr->initialized == 0) {
154	hr = CoInitialize(0);
155	if (FAILED(hr)) {
156	    Tcl_SetResult(interp,
157		    "failed to initialize the COM library", TCL_STATIC);
158	    return "";
159	}
160	tsdPtr->initialized = 1;
161	TRACE("Initialized COM library for interp 0x%08X\n", (long)interp);
162    }
163
164    /*
165     * If the interp hasn't been registered before then we need to create the
166     * registration structure and the COM object. If it has been registered
167     * already then we can reuse all and just register the new name.
168     */
169
170    riPtr = Tcl_GetAssocData(interp, "tkWinSend::ri", NULL);
171    if (riPtr == NULL) {
172	LPUNKNOWN *objPtr;
173
174	riPtr = (RegisteredInterp *) ckalloc(sizeof(RegisteredInterp));
175	memset(riPtr, 0, sizeof(RegisteredInterp));
176	riPtr->interp = interp;
177
178	objPtr = &riPtr->obj;
179	hr = TkWinSendCom_CreateInstance(interp, &IID_IUnknown,
180		(void **) objPtr);
181
182	Tcl_CreateObjCommand(interp, "send", Tk_SendObjCmd, riPtr,
183		CmdDeleteProc);
184	if (Tcl_IsSafe(interp)) {
185	    Tcl_HideCommand(interp, "send", "send");
186	}
187	Tcl_SetAssocData(interp, "tkWinSend::ri", NULL, riPtr);
188    } else {
189	RevokeObjectRegistration(riPtr);
190    }
191
192    RegisterInterp(name, riPtr);
193    return (const char *) riPtr->name;
194#endif /* TK_SEND_ENABLED_ON_WINDOWS */
195}
196
197/*
198 *----------------------------------------------------------------------
199 *
200 * TkGetInterpNames --
201 *
202 *	This function is invoked to fetch a list of all the interpreter names
203 *	currently registered for the display of a particular window.
204 *
205 * Results:
206 *	A standard Tcl return value. Interp->result will be set to hold a list
207 *	of all the interpreter names defined for tkwin's display. If an error
208 *	occurs, then TCL_ERROR is returned and interp->result will hold an
209 *	error message.
210 *
211 * Side effects:
212 *	None.
213 *
214 *----------------------------------------------------------------------
215 */
216
217int
218TkGetInterpNames(
219    Tcl_Interp *interp,		/* Interpreter for returning a result. */
220    Tk_Window tkwin)		/* Window whose display is to be used for the
221				 * lookup. */
222{
223#ifndef TK_SEND_ENABLED_ON_WINDOWS
224    /*
225     * Temporarily disabled for bug #858822
226     */
227
228    return TCL_OK;
229#else /* TK_SEND_ENABLED_ON_WINDOWS */
230
231    LPRUNNINGOBJECTTABLE pROT = NULL;
232    LPCOLESTR oleszStub = TKWINSEND_REGISTRATION_BASE;
233    HRESULT hr = S_OK;
234    Tcl_Obj *objList = NULL;
235    int result = TCL_OK;
236
237    hr = GetRunningObjectTable(0, &pROT);
238    if (SUCCEEDED(hr)) {
239	IBindCtx* pBindCtx = NULL;
240	objList = Tcl_NewListObj(0, NULL);
241	hr = CreateBindCtx(0, &pBindCtx);
242
243	if (SUCCEEDED(hr)) {
244	    IEnumMoniker* pEnum;
245
246	    hr = pROT->lpVtbl->EnumRunning(pROT, &pEnum);
247	    if (SUCCEEDED(hr)) {
248		IMoniker* pmk = NULL;
249
250		while (pEnum->lpVtbl->Next(pEnum, 1, &pmk, NULL) == S_OK) {
251		    LPOLESTR olestr;
252
253		    hr = pmk->lpVtbl->GetDisplayName(pmk, pBindCtx, NULL,
254			    &olestr);
255		    if (SUCCEEDED(hr)) {
256			IMalloc *pMalloc = NULL;
257
258			if (wcsncmp(olestr, oleszStub,
259				wcslen(oleszStub)) == 0) {
260			    LPOLESTR p = olestr + wcslen(oleszStub);
261
262			    if (*p) {
263				result = Tcl_ListObjAppendElement(interp,
264					objList, Tcl_NewUnicodeObj(p + 1, -1));
265			    }
266			}
267
268			hr = CoGetMalloc(1, &pMalloc);
269			if (SUCCEEDED(hr)) {
270			    pMalloc->lpVtbl->Free(pMalloc, (void*)olestr);
271			    pMalloc->lpVtbl->Release(pMalloc);
272			}
273		    }
274		    pmk->lpVtbl->Release(pmk);
275		}
276		pEnum->lpVtbl->Release(pEnum);
277	    }
278	    pBindCtx->lpVtbl->Release(pBindCtx);
279	}
280	pROT->lpVtbl->Release(pROT);
281    }
282
283    if (FAILED(hr)) {
284	/*
285	 * Expire the list if set.
286	 */
287
288	if (objList != NULL) {
289	    Tcl_DecrRefCount(objList);
290	}
291	Tcl_SetObjResult(interp, Win32ErrorObj(hr));
292	result = TCL_ERROR;
293    }
294
295    if (result == TCL_OK) {
296	Tcl_SetObjResult(interp, objList);
297    }
298
299    return result;
300#endif /* TK_SEND_ENABLED_ON_WINDOWS */
301}
302
303/*
304 *--------------------------------------------------------------
305 *
306 * Tk_SendCmd --
307 *
308 *	This function is invoked to process the "send" Tcl command. See the
309 *	user documentation for details on what it does.
310 *
311 * Results:
312 *	A standard Tcl result.
313 *
314 * Side effects:
315 *	See the user documentation.
316 *
317 *--------------------------------------------------------------
318 */
319
320int
321Tk_SendObjCmd(
322    ClientData clientData,	/* Information about sender (only dispPtr
323				 * field is used). */
324    Tcl_Interp *interp,		/* Current interpreter. */
325    int objc,			/* Number of arguments. */
326    Tcl_Obj *const objv[])	/* Argument strings. */
327{
328    enum {
329	SEND_ASYNC, SEND_DISPLAYOF, SEND_LAST
330    };
331    static const char *sendOptions[] = {
332	"-async",   "-displayof",   "--",  NULL
333    };
334    int result = TCL_OK;
335    int i, optind, async = 0;
336    Tcl_Obj *displayPtr = NULL;
337
338    /*
339     * Process the command options.
340     */
341
342    for (i = 1; i < objc; i++) {
343	if (Tcl_GetIndexFromObj(interp, objv[i], sendOptions,
344		"option", 0, &optind) != TCL_OK) {
345	    break;
346	}
347	if (optind == SEND_ASYNC) {
348	    ++async;
349	} else if (optind == SEND_DISPLAYOF) {
350	    displayPtr = objv[++i];
351	} else if (optind == SEND_LAST) {
352	    i++;
353	    break;
354	}
355    }
356
357    /*
358     * Ensure we still have a valid command.
359     */
360
361    if ((objc - i) < 2) {
362	Tcl_WrongNumArgs(interp, 1, objv,
363		"?-async? ?-displayof? ?--? interpName arg ?arg ...?");
364	result = TCL_ERROR;
365    }
366
367    /*
368     * We don't support displayPtr. See TIP #150.
369     */
370
371    if (displayPtr) {
372	Tcl_SetStringObj(Tcl_GetObjResult(interp),
373		"option not implemented: \"displayof\" is not available "
374		"for this platform.", -1);
375	result = TCL_ERROR;
376    }
377
378    /*
379     * Send the arguments to the foreign interp.
380     */
381    /* FIX ME: we need to check for local interp */
382    if (result == TCL_OK) {
383	LPDISPATCH pdisp;
384	result = FindInterpreterObject(interp, Tcl_GetString(objv[i]), &pdisp);
385	if (result == TCL_OK) {
386	    i++;
387	    result = Send(pdisp, interp, async, clientData, objc-i, objv+i);
388	    pdisp->lpVtbl->Release(pdisp);
389	}
390    }
391
392    return result;
393}
394
395/*
396 *--------------------------------------------------------------
397 *
398 * FindInterpreterObject --
399 *
400 *	Search the set of objects currently registered with the Running Object
401 *	Table for one which matches the registered name. Tk objects are named
402 *	using BuildMoniker by always prefixing with TclEval.
403 *
404 * Results:
405 *	If a matching object registration is found, then the registered
406 *	IDispatch interface pointer is returned. If not, then an error message
407 *	is placed in the interpreter and TCL_ERROR is returned.
408 *
409 * Side effects:
410 *	None.
411 *
412 *--------------------------------------------------------------
413 */
414
415static int
416FindInterpreterObject(
417    Tcl_Interp *interp,
418    const char *name,
419    LPDISPATCH *ppdisp)
420{
421    LPRUNNINGOBJECTTABLE pROT = NULL;
422    int result = TCL_OK;
423    HRESULT hr = GetRunningObjectTable(0, &pROT);
424
425    if (SUCCEEDED(hr)) {
426	IBindCtx* pBindCtx = NULL;
427
428	hr = CreateBindCtx(0, &pBindCtx);
429	if (SUCCEEDED(hr)) {
430	    LPMONIKER pmk = NULL;
431
432	    hr = BuildMoniker(name, &pmk);
433	    if (SUCCEEDED(hr)) {
434		IUnknown *pUnkInterp = NULL, **ppUnkInterp = &pUnkInterp;
435
436		hr = pROT->lpVtbl->IsRunning(pROT, pmk);
437		hr = pmk->lpVtbl->BindToObject(pmk, pBindCtx, NULL,
438			&IID_IUnknown, (void **) ppUnkInterp);
439		if (SUCCEEDED(hr)) {
440		    hr = pUnkInterp->lpVtbl->QueryInterface(pUnkInterp,
441			    &IID_IDispatch, (void **) ppdisp);
442		    pUnkInterp->lpVtbl->Release(pUnkInterp);
443
444		} else {
445		    Tcl_ResetResult(interp);
446		    Tcl_AppendResult(interp,
447			    "no application named \"", name, "\"", NULL);
448		    result = TCL_ERROR;
449		}
450
451		pmk->lpVtbl->Release(pmk);
452	    }
453	    pBindCtx->lpVtbl->Release(pBindCtx);
454	}
455	pROT->lpVtbl->Release(pROT);
456    }
457    if (FAILED(hr) && result == TCL_OK) {
458	Tcl_SetObjResult(interp, Win32ErrorObj(hr));
459	result = TCL_ERROR;
460    }
461    return result;
462}
463
464/*
465 *--------------------------------------------------------------
466 *
467 * CmdDeleteProc --
468 *
469 *	This function is invoked by Tcl when the "send" command is deleted in
470 *	an interpreter. It unregisters the interpreter.
471 *
472 * Results:
473 *	None.
474 *
475 * Side effects:
476 *	The interpreter given by riPtr is unregistered, the registration
477 *	structure is free'd and the COM object unregistered and released.
478 *
479 *--------------------------------------------------------------
480 */
481
482#ifdef TK_SEND_ENABLED_ON_WINDOWS
483static void
484CmdDeleteProc(
485    ClientData clientData)
486{
487    RegisteredInterp *riPtr = (RegisteredInterp *)clientData;
488
489    /*
490     * Lock the package structure in memory.
491     */
492
493    Tcl_Preserve(clientData);
494
495    /*
496     * Revoke the ROT registration.
497     */
498
499    RevokeObjectRegistration(riPtr);
500
501    /*
502     * Release the registration object.
503     */
504
505    riPtr->obj->lpVtbl->Release(riPtr->obj);
506    riPtr->obj = NULL;
507
508    Tcl_DeleteAssocData(riPtr->interp, "tkWinSend::ri");
509
510    /*
511     * Unlock the package data structure.
512     */
513
514    Tcl_Release(clientData);
515
516    ckfree(clientData);
517}
518
519/*
520 *--------------------------------------------------------------
521 *
522 * RevokeObjectRegistration --
523 *
524 *	Releases the interpreters registration object from the Running Object
525 *	Table.
526 *
527 * Results:
528 *	None.
529 *
530 * Side effects:
531 *	The stored cookie value is zeroed and the name is free'd and the
532 *	pointer set to NULL.
533 *
534 *--------------------------------------------------------------
535 */
536
537static void
538RevokeObjectRegistration(
539    RegisteredInterp *riPtr)
540{
541    LPRUNNINGOBJECTTABLE pROT = NULL;
542    HRESULT hr = S_OK;
543
544    if (riPtr->cookie != 0) {
545	hr = GetRunningObjectTable(0, &pROT);
546	if (SUCCEEDED(hr)) {
547	    hr = pROT->lpVtbl->Revoke(pROT, riPtr->cookie);
548	    pROT->lpVtbl->Release(pROT);
549	    riPtr->cookie = 0;
550	}
551    }
552
553    /*
554     * Release the name storage.
555     */
556
557    if (riPtr->name != NULL) {
558	free(riPtr->name);
559	riPtr->name = NULL;
560    }
561}
562#endif
563
564/*
565 * ----------------------------------------------------------------------
566 *
567 * InterpDeleteProc --
568 *
569 *	This is called when the interpreter is deleted and used to unregister
570 *	the COM libraries.
571 *
572 * Results:
573 *	None.
574 *
575 * Side effects:
576 *	None.
577 *
578 * ----------------------------------------------------------------------
579 */
580
581#ifdef TK_SEND_ENABLED_ON_WINDOWS
582static void
583InterpDeleteProc(
584    ClientData clientData,
585    Tcl_Interp *interp)
586{
587    CoUninitialize();
588}
589#endif
590
591/*
592 * ----------------------------------------------------------------------
593 *
594 * BuildMoniker --
595 *
596 *	Construct a moniker from the given name. This ensures that all our
597 *	monikers have the same prefix.
598 *
599 * Results:
600 *	S_OK. If the name cannot be turned into a moniker then a COM error
601 *	code is returned.
602 *
603 * Side effects:
604 *	The moniker created is stored at the address given by ppmk.
605 *
606 * ----------------------------------------------------------------------
607 */
608
609static HRESULT
610BuildMoniker(
611    const char *name,
612    LPMONIKER *ppmk)
613{
614    LPMONIKER pmkClass = NULL;
615    HRESULT hr = CreateFileMoniker(TKWINSEND_REGISTRATION_BASE, &pmkClass);
616
617    if (SUCCEEDED(hr)) {
618	LPMONIKER pmkItem = NULL;
619	Tcl_DString dString;
620
621	Tcl_DStringInit(&dString);
622	Tcl_UtfToUniCharDString(name, -1, &dString);
623	hr = CreateFileMoniker((LPOLESTR)Tcl_DStringValue(&dString), &pmkItem);
624	Tcl_DStringFree(&dString);
625	if (SUCCEEDED(hr)) {
626	    hr = pmkClass->lpVtbl->ComposeWith(pmkClass, pmkItem, FALSE, ppmk);
627	    pmkItem->lpVtbl->Release(pmkItem);
628	}
629	pmkClass->lpVtbl->Release(pmkClass);
630    }
631    return hr;
632}
633
634/*
635 * ----------------------------------------------------------------------
636 *
637 * RegisterInterp --
638 *
639 *	Attempts to register the provided name for this interpreter. If the
640 *	given name is already in use, then a numeric suffix is appended as
641 *	" #n" until we identify a unique name.
642 *
643 * Results:
644 *	Returns S_OK if successful, else a COM error code.
645 *
646 * Side effects:
647 *	Registration returns a cookie value which is stored. We also store a
648 *	copy of the name.
649 *
650 * ----------------------------------------------------------------------
651 */
652
653#ifdef TK_SEND_ENABLED_ON_WINDOWS
654static HRESULT
655RegisterInterp(
656    const char *name,
657    RegisteredInterp *riPtr)
658{
659    HRESULT hr = S_OK;
660    LPRUNNINGOBJECTTABLE pROT = NULL;
661    LPMONIKER pmk = NULL;
662    int i, offset;
663    const char *actualName = name;
664    Tcl_DString dString;
665    Tcl_DStringInit(&dString);
666
667    hr = GetRunningObjectTable(0, &pROT);
668    if (SUCCEEDED(hr)) {
669	offset = 0;
670	for (i = 1; SUCCEEDED(hr); i++) {
671	    if (i > 1) {
672		if (i == 2) {
673		    Tcl_DStringInit(&dString);
674		    Tcl_DStringAppend(&dString, name, -1);
675		    Tcl_DStringAppend(&dString, " #", 2);
676		    offset = Tcl_DStringLength(&dString);
677		    Tcl_DStringSetLength(&dString, offset+TCL_INTEGER_SPACE);
678		    actualName = Tcl_DStringValue(&dString);
679		}
680		sprintf(Tcl_DStringValue(&dString) + offset, "%d", i);
681	    }
682
683	    hr = BuildMoniker(actualName, &pmk);
684	    if (SUCCEEDED(hr)) {
685
686		hr = pROT->lpVtbl->Register(pROT,
687		    ROTFLAGS_REGISTRATIONKEEPSALIVE,
688		    riPtr->obj, pmk, &riPtr->cookie);
689
690		pmk->lpVtbl->Release(pmk);
691	    }
692
693	    if (hr == MK_S_MONIKERALREADYREGISTERED) {
694		pROT->lpVtbl->Revoke(pROT, riPtr->cookie);
695	    } else if (hr == S_OK) {
696		break;
697	    }
698	}
699
700	pROT->lpVtbl->Release(pROT);
701    }
702
703    if (SUCCEEDED(hr)) {
704	riPtr->name = strdup(actualName);
705    }
706
707    Tcl_DStringFree(&dString);
708    return hr;
709}
710#endif
711
712/*
713 * ----------------------------------------------------------------------
714 *
715 * Send --
716 *
717 *	Perform an interface call to the server object. We convert the Tcl
718 *	arguments into a BSTR using 'concat'. The result should be a BSTR that
719 *	we can set as the interp's result string.
720 *
721 * Results:
722 *	None.
723 *
724 * Side effects:
725 *	None.
726 *
727 * ----------------------------------------------------------------------
728 */
729
730static int
731Send(
732    LPDISPATCH pdispInterp,	/* Pointer to the remote interp's COM
733				 * object. */
734    Tcl_Interp *interp,		/* The local interpreter. */
735    int async,			/* Flag for the calling style. */
736    ClientData clientData,	/* The RegisteredInterp structure for this
737				 * interp. */
738    int objc,			/* Number of arguments to be sent. */
739    Tcl_Obj *const objv[])	/* The arguments to be sent. */
740{
741    VARIANT vCmd, vResult;
742    DISPPARAMS dp;
743    EXCEPINFO ei;
744    UINT uiErr = 0;
745    HRESULT hr = S_OK, ehr = S_OK;
746    Tcl_Obj *cmd = NULL;
747    DISPID dispid;
748
749    cmd = Tcl_ConcatObj(objc, objv);
750
751    /*
752     * Setup the arguments for the COM method call.
753     */
754
755    VariantInit(&vCmd);
756    VariantInit(&vResult);
757    memset(&dp, 0, sizeof(dp));
758    memset(&ei, 0, sizeof(ei));
759
760    vCmd.vt = VT_BSTR;
761    vCmd.bstrVal = SysAllocString(Tcl_GetUnicode(cmd));
762
763    dp.cArgs = 1;
764    dp.rgvarg = &vCmd;
765
766    /*
767     * Select the method to use based upon the async flag and call the method.
768     */
769
770    dispid = async ? TKWINSENDCOM_DISPID_ASYNC : TKWINSENDCOM_DISPID_SEND;
771
772    hr = pdispInterp->lpVtbl->Invoke(pdispInterp, dispid,
773	    &IID_NULL, LOCALE_SYSTEM_DEFAULT, DISPATCH_METHOD,
774	    &dp, &vResult, &ei, &uiErr);
775
776    /*
777     * Convert the result into a string and place in the interps result.
778     */
779
780    ehr = VariantChangeType(&vResult, &vResult, 0, VT_BSTR);
781    if (SUCCEEDED(ehr)) {
782	Tcl_SetObjResult(interp, Tcl_NewUnicodeObj(vResult.bstrVal, -1));
783    }
784
785    /*
786     * Errors are returned as dispatch exceptions. If an error code was
787     * returned then we decode the exception and setup the Tcl error
788     * variables.
789     */
790
791    if (hr == DISP_E_EXCEPTION) {
792	Tcl_Obj *opError, *opErrorCode, *opErrorInfo;
793
794	if (ei.bstrSource != NULL) {
795	    int len;
796	    char *szErrorInfo;
797
798	    opError = Tcl_NewUnicodeObj(ei.bstrSource, -1);
799	    Tcl_ListObjIndex(interp, opError, 0, &opErrorCode);
800	    Tcl_SetObjErrorCode(interp, opErrorCode);
801
802	    Tcl_ListObjIndex(interp, opError, 1, &opErrorInfo);
803	    szErrorInfo = Tcl_GetStringFromObj(opErrorInfo, &len);
804	    Tcl_AddObjErrorInfo(interp, szErrorInfo, len);
805	}
806    }
807
808    /*
809     * Clean up any COM allocated resources.
810     */
811
812    SysFreeString(ei.bstrDescription);
813    SysFreeString(ei.bstrSource);
814    SysFreeString(ei.bstrHelpFile);
815    VariantClear(&vCmd);
816
817    return (SUCCEEDED(hr) ? TCL_OK : TCL_ERROR);
818}
819
820/*
821 * ----------------------------------------------------------------------
822 *
823 * Win32ErrorObj --
824 *
825 *	Returns a string object containing text from a COM or Win32 error code
826 *
827 * Results:
828 *	A Tcl_Obj containing the Win32 error message.
829 *
830 * Side effects:
831 *	Removed the error message from the COM threads error object.
832 *
833 * ----------------------------------------------------------------------
834 */
835
836static Tcl_Obj*
837Win32ErrorObj(
838    HRESULT hrError)
839{
840    LPTSTR lpBuffer = NULL, p = NULL;
841    TCHAR  sBuffer[30];
842    Tcl_Obj* errPtr = NULL;
843
844    FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER | FORMAT_MESSAGE_FROM_SYSTEM,
845	    NULL, (DWORD)hrError, LANG_NEUTRAL,
846	    (LPTSTR)&lpBuffer, 0, NULL);
847
848    if (lpBuffer == NULL) {
849	lpBuffer = sBuffer;
850	wsprintf(sBuffer, TEXT("Error Code: %08lX"), hrError);
851    }
852
853    if ((p = _tcsrchr(lpBuffer, TEXT('\r'))) != NULL) {
854	*p = TEXT('\0');
855    }
856
857#ifdef _UNICODE
858    errPtr = Tcl_NewUnicodeObj(lpBuffer, (int)wcslen(lpBuffer));
859#else
860    errPtr = Tcl_NewStringObj(lpBuffer, (int)strlen(lpBuffer));
861#endif
862
863    if (lpBuffer != sBuffer) {
864	LocalFree((HLOCAL)lpBuffer);
865    }
866
867    return errPtr;
868}
869
870/*
871 * ----------------------------------------------------------------------
872 *
873 * SetErrorInfo --
874 *
875 *	Convert the error information from a Tcl interpreter into a COM
876 *	exception structure. This information is then registered with the COM
877 *	thread exception object so that it can be used for rich error
878 *	reporting by COM clients.
879 *
880 * Results:
881 *	None.
882 *
883 * Side effects:
884 *	The current COM thread has its error object modified.
885 *
886 * ----------------------------------------------------------------------
887 */
888
889void
890SetExcepInfo(
891    Tcl_Interp* interp,
892    EXCEPINFO *pExcepInfo)
893{
894    if (pExcepInfo) {
895	Tcl_Obj *opError, *opErrorInfo, *opErrorCode;
896	ICreateErrorInfo *pCEI;
897	IErrorInfo *pEI, **ppEI = &pEI;
898	HRESULT hr;
899
900	opError = Tcl_GetObjResult(interp);
901	opErrorInfo = Tcl_GetVar2Ex(interp, "errorInfo",NULL, TCL_GLOBAL_ONLY);
902	opErrorCode = Tcl_GetVar2Ex(interp, "errorCode",NULL, TCL_GLOBAL_ONLY);
903
904	if (Tcl_IsShared(opErrorCode)) {
905	    Tcl_Obj *ec = Tcl_DuplicateObj(opErrorCode);
906
907	    Tcl_IncrRefCount(ec);
908	    Tcl_DecrRefCount(opErrorCode);
909	    opErrorCode = ec;
910	}
911	Tcl_ListObjAppendElement(interp, opErrorCode, opErrorInfo);
912
913	pExcepInfo->bstrDescription = SysAllocString(Tcl_GetUnicode(opError));
914	pExcepInfo->bstrSource = SysAllocString(Tcl_GetUnicode(opErrorCode));
915	pExcepInfo->scode = E_FAIL;
916
917	hr = CreateErrorInfo(&pCEI);
918	if (SUCCEEDED(hr)) {
919	    hr = pCEI->lpVtbl->SetGUID(pCEI, &IID_IDispatch);
920	    hr = pCEI->lpVtbl->SetDescription(pCEI,
921		    pExcepInfo->bstrDescription);
922	    hr = pCEI->lpVtbl->SetSource(pCEI, pExcepInfo->bstrSource);
923	    hr = pCEI->lpVtbl->QueryInterface(pCEI, &IID_IErrorInfo,
924		    (void**) ppEI);
925	    if (SUCCEEDED(hr)) {
926		SetErrorInfo(0, pEI);
927		pEI->lpVtbl->Release(pEI);
928	    }
929	    pCEI->lpVtbl->Release(pCEI);
930	}
931    }
932}
933
934/*
935 * ----------------------------------------------------------------------
936 *
937 * TkWinSend_QueueCommand --
938 *
939 *	Queue a script for asynchronous evaluation. This is called from the
940 *	COM objects Async method.
941 *
942 * Results:
943 *	None.
944 *
945 * Side effects:
946 *	None.
947 *
948 * ----------------------------------------------------------------------
949 */
950
951int
952TkWinSend_QueueCommand(
953    Tcl_Interp *interp,
954    Tcl_Obj *cmdPtr)
955{
956    SendEvent *evPtr;
957
958    TRACE("SendQueueCommand()\n");
959
960    evPtr = (SendEvent *)ckalloc(sizeof(SendEvent));
961    evPtr->header.proc = SendEventProc;
962    evPtr->header.nextPtr = NULL;
963    evPtr->interp = interp;
964    Tcl_Preserve(evPtr->interp);
965
966    if (Tcl_IsShared(cmdPtr)) {
967	evPtr->cmdPtr = Tcl_DuplicateObj(cmdPtr);
968    } else {
969	evPtr->cmdPtr = cmdPtr;
970	Tcl_IncrRefCount(evPtr->cmdPtr);
971    }
972
973    Tcl_QueueEvent((Tcl_Event *)evPtr, TCL_QUEUE_TAIL);
974
975    return 0;
976}
977
978/*
979 * ----------------------------------------------------------------------
980 *
981 * SendEventProc --
982 *
983 *	Handle a request for an asynchronous send. Nothing is returned to the
984 *	caller so the result is discarded.
985 *
986 * Results:
987 *	Returns 1 if the event was handled or 0 to indicate it has been
988 *	deferred.
989 *
990 * Side effects:
991 *	The target interpreter's result will be modified.
992 *
993 * ----------------------------------------------------------------------
994 */
995
996static int
997SendEventProc(
998    Tcl_Event *eventPtr,
999    int flags)
1000{
1001    int result = TCL_OK;
1002    SendEvent *evPtr = (SendEvent *)eventPtr;
1003
1004    TRACE("SendEventProc\n");
1005
1006    result = Tcl_EvalObjEx(evPtr->interp, evPtr->cmdPtr,
1007	    TCL_EVAL_DIRECT | TCL_EVAL_GLOBAL);
1008
1009    Tcl_DecrRefCount(evPtr->cmdPtr);
1010    Tcl_Release(evPtr->interp);
1011
1012    return 1; /* 1 to indicate the event has been handled */
1013}
1014
1015/*
1016 * ----------------------------------------------------------------------
1017 *
1018 * SendTrace --
1019 *
1020 *	Provide trace information to the Windows debug stream. To use this -
1021 *	use the TRACE macro, which compiles to nothing when DEBUG is not
1022 *	defined.
1023 *
1024 * Results:
1025 *	None.
1026 *
1027 * Side effects:
1028 *	None.
1029 *
1030 * ----------------------------------------------------------------------
1031 */
1032
1033static void
1034SendTrace(
1035    const char *format, ...)
1036{
1037    va_list args;
1038    static char buffer[1024];
1039
1040    va_start(args, format);
1041    vsnprintf(buffer, 1023, format, args);
1042    OutputDebugString(buffer);
1043    va_end(args);
1044}
1045
1046/*
1047 * Local Variables:
1048 * mode: c
1049 * c-basic-offset: 4
1050 * fill-column: 78
1051 * End:
1052 */
1053