1/*
2 * tkWinSendCom.c --
3 *
4 *	This file provides support functions that implement the Windows "send"
5 *	command using COM interfaces, allowing commands to be passed from
6 *	interpreter to interpreter. See also tkWinSend.c, where most of the
7 *	interesting functions are.
8 *
9 * We implement a COM class for use in registering Tcl interpreters with the
10 * system's Running Object Table. This class implements an IDispatch interface
11 * with the following method:
12 *	Send(String cmd) As String
13 * In other words the Send methods takes a string and evaluates this in the
14 * Tcl interpreter. The result is returned as another string.
15 *
16 * Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net>
17 *
18 * See the file "license.terms" for information on usage and redistribution of
19 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
20 *
21 * RCS: @(#) $Id$
22 */
23
24#include "tkInt.h"
25#include "tkWinSendCom.h"
26
27/*
28 * ----------------------------------------------------------------------
29 * Non-public prototypes.
30 *
31 *	These are the interface methods for IUnknown, IDispatch and
32 *	ISupportErrorInfo.
33 *
34 * ----------------------------------------------------------------------
35 */
36
37static void		TkWinSendCom_Destroy(LPDISPATCH pdisp);
38
39static STDMETHODIMP	WinSendCom_QueryInterface(IDispatch *This,
40			    REFIID riid, void **ppvObject);
41static STDMETHODIMP_(ULONG)	WinSendCom_AddRef(IDispatch *This);
42static STDMETHODIMP_(ULONG)	WinSendCom_Release(IDispatch *This);
43static STDMETHODIMP	WinSendCom_GetTypeInfoCount(IDispatch *This,
44			    UINT *pctinfo);
45static STDMETHODIMP	WinSendCom_GetTypeInfo(IDispatch *This, UINT iTInfo,
46			    LCID lcid, ITypeInfo **ppTI);
47static STDMETHODIMP	WinSendCom_GetIDsOfNames(IDispatch *This, REFIID riid,
48			    LPOLESTR *rgszNames, UINT cNames, LCID lcid,
49			    DISPID *rgDispId);
50static STDMETHODIMP	WinSendCom_Invoke(IDispatch *This, DISPID dispidMember,
51			    REFIID riid, LCID lcid, WORD wFlags,
52			    DISPPARAMS *pDispParams, VARIANT *pvarResult,
53			    EXCEPINFO *pExcepInfo, UINT *puArgErr);
54static STDMETHODIMP	ISupportErrorInfo_QueryInterface(
55			    ISupportErrorInfo *This, REFIID riid,
56			    void **ppvObject);
57static STDMETHODIMP_(ULONG)	ISupportErrorInfo_AddRef(
58				    ISupportErrorInfo *This);
59static STDMETHODIMP_(ULONG)	ISupportErrorInfo_Release(
60				    ISupportErrorInfo *This);
61static STDMETHODIMP	ISupportErrorInfo_InterfaceSupportsErrorInfo(
62			    ISupportErrorInfo *This, REFIID riid);
63static HRESULT		Send(TkWinSendCom *obj, VARIANT vCmd,
64			    VARIANT *pvResult, EXCEPINFO *pExcepInfo,
65			    UINT *puArgErr);
66static HRESULT		Async(TkWinSendCom *obj, VARIANT Cmd,
67			    EXCEPINFO *pExcepInfo, UINT *puArgErr);
68
69/*
70 * ----------------------------------------------------------------------
71 *
72 * CreateInstance --
73 *
74 *	Create and initialises a new instance of the WinSend COM class and
75 *	returns an interface pointer for you to use.
76 *
77 * ----------------------------------------------------------------------
78 */
79
80HRESULT
81TkWinSendCom_CreateInstance(
82    Tcl_Interp *interp,
83    REFIID riid,
84    void **ppv)
85{
86    /*
87     * Construct v-tables for each interface.
88     */
89
90    static IDispatchVtbl vtbl = {
91	WinSendCom_QueryInterface,
92	WinSendCom_AddRef,
93	WinSendCom_Release,
94	WinSendCom_GetTypeInfoCount,
95	WinSendCom_GetTypeInfo,
96	WinSendCom_GetIDsOfNames,
97	WinSendCom_Invoke,
98    };
99    static ISupportErrorInfoVtbl vtbl2 = {
100	ISupportErrorInfo_QueryInterface,
101	ISupportErrorInfo_AddRef,
102	ISupportErrorInfo_Release,
103	ISupportErrorInfo_InterfaceSupportsErrorInfo,
104    };
105    HRESULT hr = S_OK;
106    TkWinSendCom *obj = NULL;
107
108    /*
109     * This had probably better always be globally visible memory so we shall
110     * use the COM Task allocator.
111     */
112
113    obj = (TkWinSendCom *) CoTaskMemAlloc(sizeof(TkWinSendCom));
114    if (obj == NULL) {
115	*ppv = NULL;
116	hr = E_OUTOFMEMORY;
117    } else {
118	obj->lpVtbl = &vtbl;
119	obj->lpVtbl2 = &vtbl2;
120	obj->refcount = 0;
121	obj->interp = interp;
122
123	/*
124	 * lock the interp? Tcl_AddRef/Retain?
125	 */
126
127	hr = obj->lpVtbl->QueryInterface((IDispatch*)obj, riid, ppv);
128    }
129
130    return hr;
131}
132
133/*
134 * ----------------------------------------------------------------------
135 *
136 * TkWinSendCom_Destroy --
137 *
138 *	This helper function is the destructor for our COM class.
139 *
140 * Results:
141 *	None.
142 *
143 * Side effects:
144 *	Releases the storage allocated for this object.
145 *
146 * ----------------------------------------------------------------------
147 */
148static void
149TkWinSendCom_Destroy(
150    LPDISPATCH pdisp)
151{
152    CoTaskMemFree((void*)pdisp);
153}
154
155/*
156 * ----------------------------------------------------------------------
157 *
158 * IDispatch --
159 *
160 *	The IDispatch interface implements the 'late-binding' COM methods
161 *	typically used by scripting COM clients. The Invoke method is the most
162 *	important one.
163 *
164 * ----------------------------------------------------------------------
165 */
166
167static STDMETHODIMP
168WinSendCom_QueryInterface(
169    IDispatch *This,
170    REFIID riid,
171    void **ppvObject)
172{
173    HRESULT hr = E_NOINTERFACE;
174    TkWinSendCom *this = (TkWinSendCom*)This;
175    *ppvObject = NULL;
176
177    if (memcmp(riid, &IID_IUnknown, sizeof(IID)) == 0
178	    || memcmp(riid, &IID_IDispatch, sizeof(IID)) == 0) {
179	*ppvObject = (void**)this;
180	this->lpVtbl->AddRef(This);
181	hr = S_OK;
182    } else if (memcmp(riid, &IID_ISupportErrorInfo, sizeof(IID)) == 0) {
183	*ppvObject = (void**)(this + 1);
184	this->lpVtbl2->AddRef((ISupportErrorInfo*)(this + 1));
185	hr = S_OK;
186    }
187    return hr;
188}
189
190static STDMETHODIMP_(ULONG)
191WinSendCom_AddRef(
192    IDispatch *This)
193{
194    TkWinSendCom *this = (TkWinSendCom*)This;
195
196    return InterlockedIncrement(&this->refcount);
197}
198
199static STDMETHODIMP_(ULONG)
200WinSendCom_Release(
201    IDispatch *This)
202{
203    long r = 0;
204    TkWinSendCom *this = (TkWinSendCom*)This;
205
206    if ((r = InterlockedDecrement(&this->refcount)) == 0) {
207	TkWinSendCom_Destroy(This);
208    }
209    return r;
210}
211
212static STDMETHODIMP
213WinSendCom_GetTypeInfoCount(
214    IDispatch *This,
215    UINT *pctinfo)
216{
217    HRESULT hr = E_POINTER;
218
219    if (pctinfo != NULL) {
220	*pctinfo = 0;
221	hr = S_OK;
222    }
223    return hr;
224}
225
226static STDMETHODIMP
227WinSendCom_GetTypeInfo(
228    IDispatch *This,
229    UINT iTInfo,
230    LCID lcid,
231    ITypeInfo **ppTI)
232{
233    HRESULT hr = E_POINTER;
234
235    if (ppTI) {
236	*ppTI = NULL;
237	hr = E_NOTIMPL;
238    }
239    return hr;
240}
241
242static STDMETHODIMP
243WinSendCom_GetIDsOfNames(
244    IDispatch *This,
245    REFIID riid,
246    LPOLESTR *rgszNames,
247    UINT cNames,
248    LCID lcid,
249    DISPID *rgDispId)
250{
251    HRESULT hr = E_POINTER;
252
253    if (rgDispId) {
254	hr = DISP_E_UNKNOWNNAME;
255	if (_wcsicmp(*rgszNames, L"Send") == 0) {
256	    *rgDispId = TKWINSENDCOM_DISPID_SEND, hr = S_OK;
257	} else if (_wcsicmp(*rgszNames, L"Async") == 0) {
258	    *rgDispId = TKWINSENDCOM_DISPID_ASYNC, hr = S_OK;
259	}
260    }
261    return hr;
262}
263
264static STDMETHODIMP
265WinSendCom_Invoke(
266    IDispatch *This,
267    DISPID dispidMember,
268    REFIID riid,
269    LCID lcid,
270    WORD wFlags,
271    DISPPARAMS *pDispParams,
272    VARIANT *pvarResult,
273    EXCEPINFO *pExcepInfo,
274    UINT *puArgErr)
275{
276    HRESULT hr = DISP_E_MEMBERNOTFOUND;
277    TkWinSendCom *this = (TkWinSendCom*)This;
278
279    switch (dispidMember) {
280    case TKWINSENDCOM_DISPID_SEND:
281	if (wFlags | DISPATCH_METHOD) {
282	    if (pDispParams->cArgs != 1) {
283		hr = DISP_E_BADPARAMCOUNT;
284	    } else {
285		hr = Send(this, pDispParams->rgvarg[0], pvarResult,
286			pExcepInfo, puArgErr);
287	    }
288	}
289	break;
290
291    case TKWINSENDCOM_DISPID_ASYNC:
292	if (wFlags | DISPATCH_METHOD) {
293	    if (pDispParams->cArgs != 1) {
294		hr = DISP_E_BADPARAMCOUNT;
295	    } else {
296		hr = Async(this, pDispParams->rgvarg[0], pExcepInfo, puArgErr);
297	    }
298	}
299	break;
300    }
301    return hr;
302}
303
304/*
305 * ----------------------------------------------------------------------
306 *
307 * ISupportErrorInfo --
308 *
309 *	This interface provides rich error information to COM clients. Used by
310 *	VB and scripting COM clients.
311 *
312 * ----------------------------------------------------------------------
313 */
314
315static STDMETHODIMP
316ISupportErrorInfo_QueryInterface(
317    ISupportErrorInfo *This,
318    REFIID riid,
319    void **ppvObject)
320{
321    TkWinSendCom *this = (TkWinSendCom*)(This - 1);
322
323    return this->lpVtbl->QueryInterface((IDispatch*)this, riid, ppvObject);
324}
325
326static STDMETHODIMP_(ULONG)
327ISupportErrorInfo_AddRef(
328    ISupportErrorInfo *This)
329{
330    TkWinSendCom *this = (TkWinSendCom*)(This - 1);
331
332    return InterlockedIncrement(&this->refcount);
333}
334
335static STDMETHODIMP_(ULONG)
336ISupportErrorInfo_Release(
337    ISupportErrorInfo *This)
338{
339    TkWinSendCom *this = (TkWinSendCom*)(This - 1);
340
341    return this->lpVtbl->Release((IDispatch*)this);
342}
343
344static STDMETHODIMP
345ISupportErrorInfo_InterfaceSupportsErrorInfo(
346    ISupportErrorInfo *This,
347    REFIID riid)
348{
349    /*TkWinSendCom *this = (TkWinSendCom*)(This - 1);*/
350    return S_OK; /* or S_FALSE */
351}
352
353/*
354 * ----------------------------------------------------------------------
355 *
356 * Async --
357 *
358 *	Queues the command for evaluation in the assigned interpreter.
359 *
360 * Results:
361 *	A standard COM HRESULT is returned. The Tcl result is discarded.
362 *
363 * Side effects:
364 *	The interpreters state and result will be modified.
365 *
366 * ----------------------------------------------------------------------
367 */
368
369static HRESULT
370Async(
371    TkWinSendCom *obj,
372    VARIANT Cmd,
373    EXCEPINFO *pExcepInfo,
374    UINT *puArgErr)
375{
376    HRESULT hr = S_OK;
377    int result = TCL_OK;
378    VARIANT vCmd;
379
380    VariantInit(&vCmd);
381
382    hr = VariantChangeType(&vCmd, &Cmd, 0, VT_BSTR);
383    if (FAILED(hr)) {
384	Tcl_SetStringObj(Tcl_GetObjResult(obj->interp),
385		"invalid args: Async(command)", -1);
386	SetExcepInfo(obj->interp, pExcepInfo);
387	hr = DISP_E_EXCEPTION;
388    }
389
390    if (SUCCEEDED(hr)) {
391	if (obj->interp) {
392	    Tcl_Obj *scriptPtr = Tcl_NewUnicodeObj(vCmd.bstrVal,
393		    (int)SysStringLen(vCmd.bstrVal));
394	    result = TkWinSend_QueueCommand(obj->interp, scriptPtr);
395	}
396    }
397
398    VariantClear(&vCmd);
399
400    return hr;
401}
402
403/*
404 * ----------------------------------------------------------------------
405 *
406 * Send --
407 *
408 *	Evaluates the string in the assigned interpreter. If the result is a
409 *	valid address then set it to the result returned by the evaluation.
410 *	Tcl exceptions are converted into COM exceptions.
411 *
412 * Results:
413 *	A standard COM HRESULT is returned. The Tcl result is set as the
414 *	method calls result.
415 *
416 * Side effects:
417 *	The interpreters state and result will be modified.
418 *
419 * ----------------------------------------------------------------------
420 */
421
422static HRESULT
423Send(
424    TkWinSendCom *obj,
425    VARIANT vCmd,
426    VARIANT *pvResult,
427    EXCEPINFO *pExcepInfo,
428    UINT *puArgErr)
429{
430    HRESULT hr = S_OK;
431    int result = TCL_OK;
432    VARIANT v;
433
434    VariantInit(&v);
435    hr = VariantChangeType(&v, &vCmd, 0, VT_BSTR);
436    if (SUCCEEDED(hr)) {
437	if (obj->interp) {
438	    Tcl_Obj *scriptPtr = Tcl_NewUnicodeObj(v.bstrVal,
439		    (int)SysStringLen(v.bstrVal));
440
441	    result = Tcl_EvalObjEx(obj->interp, scriptPtr,
442		    TCL_EVAL_DIRECT | TCL_EVAL_GLOBAL);
443	    if (pvResult) {
444		VariantInit(pvResult);
445		pvResult->vt = VT_BSTR;
446		pvResult->bstrVal = SysAllocString(
447			Tcl_GetUnicode(Tcl_GetObjResult(obj->interp)));
448	    }
449	    if (result == TCL_ERROR) {
450		hr = DISP_E_EXCEPTION;
451		SetExcepInfo(obj->interp, pExcepInfo);
452	    }
453	}
454	VariantClear(&v);
455    }
456    return hr;
457}
458
459/*
460 * Local Variables:
461 * mode: c
462 * c-basic-offset: 4
463 * fill-column: 78
464 * End:
465 */
466