diff options
Diffstat (limited to 'win/tkWinSendCom.c')
-rw-r--r-- | win/tkWinSendCom.c | 463 |
1 files changed, 463 insertions, 0 deletions
diff --git a/win/tkWinSendCom.c b/win/tkWinSendCom.c new file mode 100644 index 0000000..59e2b69 --- /dev/null +++ b/win/tkWinSendCom.c @@ -0,0 +1,463 @@ +/* + * 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; + int result = TCL_OK; + VARIANT vCmd; + + VariantInit(&vCmd); + + hr = VariantChangeType(&vCmd, &Cmd, 0, VT_BSTR); + if (FAILED(hr)) { + Tcl_SetStringObj(Tcl_GetObjResult(obj->interp), + "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)); + result = 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: + */ |