tkWinSendCom.c

/*
 * tkWinSendCom.c --
 *
 *	This file provides support functions that implement the Windows "send"
 *	command using COM interfaces, allowing commands to be passed from
 *	interpreter to interpreter. See also tkWinSend.c, where most of the
 *	interesting functions are.
 *
 * We implement a COM class for use in registering Tcl interpreters with the
 * system's Running Object Table. This class implements an IDispatch interface
 * with the following method:
 *	Send(String cmd) As String
 * In other words the Send methods takes a string and evaluates this in the
 * Tcl interpreter. The result is returned as another string.
 *
 * Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net>
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include "tkInt.h"
#include "tkWinSendCom.h"

/*
 * ----------------------------------------------------------------------
 * Non-public prototypes.
 *
 *	These are the interface methods for IUnknown, IDispatch and
 *	ISupportErrorInfo.
 *
 * ----------------------------------------------------------------------
 */

static void		TkWinSendCom_Destroy(LPDISPATCH pdisp);

static STDMETHODIMP	WinSendCom_QueryInterface(IDispatch *This,
			    REFIID riid, void **ppvObject);
static STDMETHODIMP_(ULONG)	WinSendCom_AddRef(IDispatch *This);
static STDMETHODIMP_(ULONG)	WinSendCom_Release(IDispatch *This);
static STDMETHODIMP	WinSendCom_GetTypeInfoCount(IDispatch *This,
			    UINT *pctinfo);
static STDMETHODIMP	WinSendCom_GetTypeInfo(IDispatch *This, UINT iTInfo,
			    LCID lcid, ITypeInfo **ppTI);
static STDMETHODIMP	WinSendCom_GetIDsOfNames(IDispatch *This, REFIID riid,
			    LPOLESTR *rgszNames, UINT cNames, LCID lcid,
			    DISPID *rgDispId);
static STDMETHODIMP	WinSendCom_Invoke(IDispatch *This, DISPID dispidMember,
			    REFIID riid, LCID lcid, WORD wFlags,
			    DISPPARAMS *pDispParams, VARIANT *pvarResult,
			    EXCEPINFO *pExcepInfo, UINT *puArgErr);
static STDMETHODIMP	ISupportErrorInfo_QueryInterface(
			    ISupportErrorInfo *This, REFIID riid,
			    void **ppvObject);
static STDMETHODIMP_(ULONG)	ISupportErrorInfo_AddRef(
				    ISupportErrorInfo *This);
static STDMETHODIMP_(ULONG)	ISupportErrorInfo_Release(
				    ISupportErrorInfo *This);
static STDMETHODIMP	ISupportErrorInfo_InterfaceSupportsErrorInfo(
			    ISupportErrorInfo *This, REFIID riid);
static HRESULT		Send(TkWinSendCom *obj, VARIANT vCmd,
			    VARIANT *pvResult, EXCEPINFO *pExcepInfo,
			    UINT *puArgErr);
static HRESULT		Async(TkWinSendCom *obj, VARIANT Cmd,
			    EXCEPINFO *pExcepInfo, UINT *puArgErr);

/*
 * ----------------------------------------------------------------------
 *
 * CreateInstance --
 *
 *	Create and initialises a new instance of the WinSend COM class and
 *	returns an interface pointer for you to use.
 *
 * ----------------------------------------------------------------------
 */

HRESULT
TkWinSendCom_CreateInstance(
    Tcl_Interp *interp,
    REFIID riid,
    void **ppv)
{
    /*
     * Construct v-tables for each interface.
     */

    static IDispatchVtbl vtbl = {
	WinSendCom_QueryInterface,
	WinSendCom_AddRef,
	WinSendCom_Release,
	WinSendCom_GetTypeInfoCount,
	WinSendCom_GetTypeInfo,
	WinSendCom_GetIDsOfNames,
	WinSendCom_Invoke,
    };
    static ISupportErrorInfoVtbl vtbl2 = {
	ISupportErrorInfo_QueryInterface,
	ISupportErrorInfo_AddRef,
	ISupportErrorInfo_Release,
	ISupportErrorInfo_InterfaceSupportsErrorInfo,
    };
    HRESULT hr = S_OK;
    TkWinSendCom *obj = NULL;

    /*
     * This had probably better always be globally visible memory so we shall
     * use the COM Task allocator.
     */

    obj = (TkWinSendCom *) CoTaskMemAlloc(sizeof(TkWinSendCom));
    if (obj == NULL) {
	*ppv = NULL;
	hr = E_OUTOFMEMORY;
    } else {
	obj->lpVtbl = &vtbl;
	obj->lpVtbl2 = &vtbl2;
	obj->refcount = 0;
	obj->interp = interp;

	/*
	 * lock the interp? Tcl_AddRef/Retain?
	 */

	hr = obj->lpVtbl->QueryInterface((IDispatch*)obj, riid, ppv);
    }

    return hr;
}

/*
 * ----------------------------------------------------------------------
 *
 * TkWinSendCom_Destroy --
 *
 *	This helper function is the destructor for our COM class.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Releases the storage allocated for this object.
 *
 * ----------------------------------------------------------------------
 */
static void
TkWinSendCom_Destroy(
    LPDISPATCH pdisp)
{
    CoTaskMemFree((void*)pdisp);
}

/*
 * ----------------------------------------------------------------------
 *
 * IDispatch --
 *
 *	The IDispatch interface implements the 'late-binding' COM methods
 *	typically used by scripting COM clients. The Invoke method is the most
 *	important one.
 *
 * ----------------------------------------------------------------------
 */

static STDMETHODIMP
WinSendCom_QueryInterface(
    IDispatch *This,
    REFIID riid,
    void **ppvObject)
{
    HRESULT hr = E_NOINTERFACE;
    TkWinSendCom *this = (TkWinSendCom*)This;
    *ppvObject = NULL;

    if (memcmp(riid, &IID_IUnknown, sizeof(IID)) == 0
	    || memcmp(riid, &IID_IDispatch, sizeof(IID)) == 0) {
	*ppvObject = (void**)this;
	this->lpVtbl->AddRef(This);
	hr = S_OK;
    } else if (memcmp(riid, &IID_ISupportErrorInfo, sizeof(IID)) == 0) {
	*ppvObject = (void**)(this + 1);
	this->lpVtbl2->AddRef((ISupportErrorInfo*)(this + 1));
	hr = S_OK;
    }
    return hr;
}

static STDMETHODIMP_(ULONG)
WinSendCom_AddRef(
    IDispatch *This)
{
    TkWinSendCom *this = (TkWinSendCom*)This;

    return InterlockedIncrement(&this->refcount);
}

static STDMETHODIMP_(ULONG)
WinSendCom_Release(
    IDispatch *This)
{
    long r = 0;
    TkWinSendCom *this = (TkWinSendCom*)This;

    if ((r = InterlockedDecrement(&this->refcount)) == 0) {
	TkWinSendCom_Destroy(This);
    }
    return r;
}

static STDMETHODIMP
WinSendCom_GetTypeInfoCount(
    IDispatch *This,
    UINT *pctinfo)
{
    HRESULT hr = E_POINTER;

    if (pctinfo != NULL) {
	*pctinfo = 0;
	hr = S_OK;
    }
    return hr;
}

static STDMETHODIMP
WinSendCom_GetTypeInfo(
    IDispatch *This,
    UINT iTInfo,
    LCID lcid,
    ITypeInfo **ppTI)
{
    HRESULT hr = E_POINTER;

    if (ppTI) {
	*ppTI = NULL;
	hr = E_NOTIMPL;
    }
    return hr;
}

static STDMETHODIMP
WinSendCom_GetIDsOfNames(
    IDispatch *This,
    REFIID riid,
    LPOLESTR *rgszNames,
    UINT cNames,
    LCID lcid,
    DISPID *rgDispId)
{
    HRESULT hr = E_POINTER;

    if (rgDispId) {
	hr = DISP_E_UNKNOWNNAME;
	if (_wcsicmp(*rgszNames, L"Send") == 0) {
	    *rgDispId = TKWINSENDCOM_DISPID_SEND, hr = S_OK;
	} else if (_wcsicmp(*rgszNames, L"Async") == 0) {
	    *rgDispId = TKWINSENDCOM_DISPID_ASYNC, hr = S_OK;
	}
    }
    return hr;
}

static STDMETHODIMP
WinSendCom_Invoke(
    IDispatch *This,
    DISPID dispidMember,
    REFIID riid,
    LCID lcid,
    WORD wFlags,
    DISPPARAMS *pDispParams,
    VARIANT *pvarResult,
    EXCEPINFO *pExcepInfo,
    UINT *puArgErr)
{
    HRESULT hr = DISP_E_MEMBERNOTFOUND;
    TkWinSendCom *this = (TkWinSendCom*)This;

    switch (dispidMember) {
    case TKWINSENDCOM_DISPID_SEND:
	if (wFlags | DISPATCH_METHOD) {
	    if (pDispParams->cArgs != 1) {
		hr = DISP_E_BADPARAMCOUNT;
	    } else {
		hr = Send(this, pDispParams->rgvarg[0], pvarResult,
			pExcepInfo, puArgErr);
	    }
	}
	break;

    case TKWINSENDCOM_DISPID_ASYNC:
	if (wFlags | DISPATCH_METHOD) {
	    if (pDispParams->cArgs != 1) {
		hr = DISP_E_BADPARAMCOUNT;
	    } else {
		hr = Async(this, pDispParams->rgvarg[0], pExcepInfo, puArgErr);
	    }
	}
	break;
    }
    return hr;
}

/*
 * ----------------------------------------------------------------------
 *
 * ISupportErrorInfo --
 *
 *	This interface provides rich error information to COM clients. Used by
 *	VB and scripting COM clients.
 *
 * ----------------------------------------------------------------------
 */

static STDMETHODIMP
ISupportErrorInfo_QueryInterface(
    ISupportErrorInfo *This,
    REFIID riid,
    void **ppvObject)
{
    TkWinSendCom *this = (TkWinSendCom*)(This - 1);

    return this->lpVtbl->QueryInterface((IDispatch*)this, riid, ppvObject);
}

static STDMETHODIMP_(ULONG)
ISupportErrorInfo_AddRef(
    ISupportErrorInfo *This)
{
    TkWinSendCom *this = (TkWinSendCom*)(This - 1);

    return InterlockedIncrement(&this->refcount);
}

static STDMETHODIMP_(ULONG)
ISupportErrorInfo_Release(
    ISupportErrorInfo *This)
{
    TkWinSendCom *this = (TkWinSendCom*)(This - 1);

    return this->lpVtbl->Release((IDispatch*)this);
}

static STDMETHODIMP
ISupportErrorInfo_InterfaceSupportsErrorInfo(
    ISupportErrorInfo *This,
    REFIID riid)
{
    /*TkWinSendCom *this = (TkWinSendCom*)(This - 1);*/
    return S_OK; /* or S_FALSE */
}

/*
 * ----------------------------------------------------------------------
 *
 * Async --
 *
 *	Queues the command for evaluation in the assigned interpreter.
 *
 * Results:
 *	A standard COM HRESULT is returned. The Tcl result is discarded.
 *
 * Side effects:
 *	The interpreters state and result will be modified.
 *
 * ----------------------------------------------------------------------
 */

static HRESULT
Async(
    TkWinSendCom *obj,
    VARIANT Cmd,
    EXCEPINFO *pExcepInfo,
    UINT *puArgErr)
{
    HRESULT hr = S_OK;
    VARIANT vCmd;

    VariantInit(&vCmd);

    hr = VariantChangeType(&vCmd, &Cmd, 0, VT_BSTR);
    if (FAILED(hr)) {
	Tcl_SetObjResult(obj->interp, Tcl_NewStringObj(
		"invalid args: Async(command)", -1));
	SetExcepInfo(obj->interp, pExcepInfo);
	hr = DISP_E_EXCEPTION;
    }

    if (SUCCEEDED(hr)) {
	if (obj->interp) {
	    Tcl_Obj *scriptPtr = Tcl_NewUnicodeObj(vCmd.bstrVal,
		    (int) SysStringLen(vCmd.bstrVal));

	    TkWinSend_QueueCommand(obj->interp, scriptPtr);
	}
    }

    VariantClear(&vCmd);
    return hr;
}

/*
 * ----------------------------------------------------------------------
 *
 * Send --
 *
 *	Evaluates the string in the assigned interpreter. If the result is a
 *	valid address then set it to the result returned by the evaluation.
 *	Tcl exceptions are converted into COM exceptions.
 *
 * Results:
 *	A standard COM HRESULT is returned. The Tcl result is set as the
 *	method calls result.
 *
 * Side effects:
 *	The interpreters state and result will be modified.
 *
 * ----------------------------------------------------------------------
 */

static HRESULT
Send(
    TkWinSendCom *obj,
    VARIANT vCmd,
    VARIANT *pvResult,
    EXCEPINFO *pExcepInfo,
    UINT *puArgErr)
{
    HRESULT hr = S_OK;
    int result = TCL_OK;
    VARIANT v;

    VariantInit(&v);
    hr = VariantChangeType(&v, &vCmd, 0, VT_BSTR);
    if (SUCCEEDED(hr)) {
	if (obj->interp) {
	    Tcl_Obj *scriptPtr = Tcl_NewUnicodeObj(v.bstrVal,
		    (int)SysStringLen(v.bstrVal));

	    result = Tcl_EvalObjEx(obj->interp, scriptPtr,
		    TCL_EVAL_DIRECT | TCL_EVAL_GLOBAL);
	    if (pvResult) {
		VariantInit(pvResult);
		pvResult->vt = VT_BSTR;
		pvResult->bstrVal = SysAllocString(
			Tcl_GetUnicode(Tcl_GetObjResult(obj->interp)));
	    }
	    if (result == TCL_ERROR) {
		hr = DISP_E_EXCEPTION;
		SetExcepInfo(obj->interp, pExcepInfo);
	    }
	}
	VariantClear(&v);
    }
    return hr;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */