diff options
author | patthoyts <patthoyts@noemail.net> | 2003-09-26 23:59:24 (GMT) |
---|---|---|
committer | patthoyts <patthoyts@noemail.net> | 2003-09-26 23:59:24 (GMT) |
commit | 01d37edb8e539a86e465cfe1c959c86d06a433a3 (patch) | |
tree | 8e5ac9459b553fd73a171025472ca655c7d60ae1 /win/tkWinSendCom.c | |
parent | d03f0ad410361da16bf4ee96cd2d3652b82e5f98 (diff) | |
download | tk-01d37edb8e539a86e465cfe1c959c86d06a433a3.zip tk-01d37edb8e539a86e465cfe1c959c86d06a433a3.tar.gz tk-01d37edb8e539a86e465cfe1c959c86d06a433a3.tar.bz2 |
* win/makefile.vc: Implementation of TIP #150, "Provide
* win/tkWinSend.c: 'send' command for Windows"
* win/tkWinSendCom.h:
* win/tkWinSendCom.c:
FossilOrigin-Name: 0ac88e3771844bf1cbca4a2f9343139667dd4d43
Diffstat (limited to 'win/tkWinSendCom.c')
-rw-r--r-- | win/tkWinSendCom.c | 431 |
1 files changed, 431 insertions, 0 deletions
diff --git a/win/tkWinSendCom.c b/win/tkWinSendCom.c new file mode 100644 index 0000000..325f127 --- /dev/null +++ b/win/tkWinSendCom.c @@ -0,0 +1,431 @@ +/* + * tkWinSend.c -- + * + * This file provides procedures that implement the Windows "send" + * command, allowing commands to be passed from interpreter + * to interpreter. + * + * 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. + * + * RCS: @(#) $Id: tkWinSendCom.c,v 1.1 2003/09/26 23:59:26 patthoyts Exp $ + */ + +#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 r = 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, + SysStringLen(vCmd.bstrVal)); + r = 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 r = 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, + SysStringLen(v.bstrVal)); + + r = 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 (r == TCL_ERROR) + { + hr = DISP_E_EXCEPTION; + SetExcepInfo(obj->interp, pExcepInfo); + } + } + VariantClear(&v); + } + return hr; +} + +/* + * Local Variables: + * mode: c + * tab-width: 8 + * c-indentation-style: tcltk + * End: + */ |