X-Git-Url: http://git.osdn.net/view?a=blobdiff_plain;f=util%2Fsrc%2FTclTk%2Ftk8.6.12%2Fwin%2FtkWinSendCom.c;fp=util%2Fsrc%2FTclTk%2Ftk8.6.12%2Fwin%2FtkWinSendCom.c;h=536c6c101a439504848fc77de24f723fc72ecec9;hb=c46db33a83894f24189046ef665713fe320fef71;hp=0000000000000000000000000000000000000000;hpb=542a195bc3d4acf4245305f6be3f1ca58d072076;p=eos%2Fbase.git diff --git a/util/src/TclTk/tk8.6.12/win/tkWinSendCom.c b/util/src/TclTk/tk8.6.12/win/tkWinSendCom.c new file mode 100644 index 0000000000..536c6c101a --- /dev/null +++ b/util/src/TclTk/tk8.6.12/win/tkWinSendCom.c @@ -0,0 +1,494 @@ +/* + * 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 + * + * 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, + }; + 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; + return E_OUTOFMEMORY; + } + + obj->lpVtbl = &vtbl; + obj->lpVtbl2 = &vtbl2; + obj->refcount = 0; + obj->interp = interp; + + /* + * lock the interp? Tcl_AddRef/Retain? + */ + + return obj->lpVtbl->QueryInterface((IDispatch *) obj, riid, ppv); +} + +/* + * ---------------------------------------------------------------------- + * + * 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 *sendCom = (TkWinSendCom *) This; + *ppvObject = NULL; + + if (memcmp(riid, &IID_IUnknown, sizeof(IID)) == 0 + || memcmp(riid, &IID_IDispatch, sizeof(IID)) == 0) { + *ppvObject = (void **) sendCom; + sendCom->lpVtbl->AddRef(This); + hr = S_OK; + } else if (memcmp(riid, &IID_ISupportErrorInfo, sizeof(IID)) == 0) { + *ppvObject = (void **) (sendCom + 1); + sendCom->lpVtbl2->AddRef((ISupportErrorInfo *) (sendCom + 1)); + hr = S_OK; + } + return hr; +} + +static STDMETHODIMP_(ULONG) +WinSendCom_AddRef( + IDispatch *This) +{ + TkWinSendCom *sendCom = (TkWinSendCom*)This; + + return InterlockedIncrement(&sendCom->refcount); +} + +static STDMETHODIMP_(ULONG) +WinSendCom_Release( + IDispatch *This) +{ + long r = 0; + TkWinSendCom *sendCom = (TkWinSendCom*)This; + + if ((r = InterlockedDecrement(&sendCom->refcount)) == 0) { + TkWinSendCom_Destroy(This); + } + return r; +} + +static STDMETHODIMP +WinSendCom_GetTypeInfoCount( + IDispatch *This, + UINT *pctinfo) +{ + HRESULT hr = E_POINTER; + (void)This; + + 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; + (void)This; + (void)iTInfo; + (void)lcid; + + 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; + (void)This; + (void)riid; + (void)cNames; + (void)lcid; + + 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 *sendCom = (TkWinSendCom*)This; + (void)riid; + (void)lcid; + + switch (dispidMember) { + case TKWINSENDCOM_DISPID_SEND: + if (wFlags | DISPATCH_METHOD) { + if (pDispParams->cArgs != 1) { + hr = DISP_E_BADPARAMCOUNT; + } else { + hr = Send(sendCom, 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(sendCom, 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 *sendCom = (TkWinSendCom *)(This - 1); + + return sendCom->lpVtbl->QueryInterface((IDispatch *) sendCom, riid, ppvObject); +} + +static STDMETHODIMP_(ULONG) +ISupportErrorInfo_AddRef( + ISupportErrorInfo *This) +{ + TkWinSendCom *sendCom = (TkWinSendCom *)(This - 1); + + return InterlockedIncrement(&sendCom->refcount); +} + +static STDMETHODIMP_(ULONG) +ISupportErrorInfo_Release( + ISupportErrorInfo *This) +{ + TkWinSendCom *sendCom = (TkWinSendCom *)(This - 1); + + return sendCom->lpVtbl->Release((IDispatch *) sendCom); +} + +static STDMETHODIMP +ISupportErrorInfo_InterfaceSupportsErrorInfo( + ISupportErrorInfo *This, + REFIID riid) +{ + (void)This; + (void)riid; + + /*TkWinSendCom *sendCom = (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; + Tcl_DString ds; + (void)puArgErr; + + VariantInit(&vCmd); + + hr = VariantChangeType(&vCmd, &Cmd, 0, VT_BSTR); + if (FAILED(hr)) { + Tcl_SetObjResult(obj->interp, Tcl_NewStringObj( + "invalid args: Async(command)", -1)); + TkWinSend_SetExcepInfo(obj->interp, pExcepInfo); + hr = DISP_E_EXCEPTION; + } + + if (SUCCEEDED(hr) && obj->interp) { + Tcl_Obj *scriptPtr; + + Tcl_DStringInit(&ds); + Tcl_WCharToUtfDString(vCmd.bstrVal, SysStringLen(vCmd.bstrVal), &ds); + scriptPtr = + Tcl_NewStringObj(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)); + Tcl_DStringFree(&ds); + 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; + Tcl_Interp *interp = obj->interp; + Tcl_Obj *scriptPtr; + Tcl_DString ds; + (void)puArgErr; + + if (interp == NULL) { + return S_OK; + } + VariantInit(&v); + hr = VariantChangeType(&v, &vCmd, 0, VT_BSTR); + if (!SUCCEEDED(hr)) { + return hr; + } + + Tcl_DStringInit(&ds); + Tcl_WCharToUtfDString(v.bstrVal, SysStringLen(v.bstrVal), &ds); + scriptPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)); + Tcl_DStringFree(&ds); + Tcl_Preserve(interp); + Tcl_IncrRefCount(scriptPtr); + result = Tcl_EvalObjEx(interp, scriptPtr, + TCL_EVAL_DIRECT | TCL_EVAL_GLOBAL); + Tcl_DecrRefCount(scriptPtr); + if (pvResult != NULL) { + Tcl_Obj *obj; + const char *src; + + VariantInit(pvResult); + pvResult->vt = VT_BSTR; + obj = Tcl_GetObjResult(interp); + src = Tcl_GetString(obj); + Tcl_DStringInit(&ds); + pvResult->bstrVal = SysAllocString(Tcl_UtfToWCharDString(src, obj->length, &ds)); + Tcl_DStringFree(&ds); + } + if (result == TCL_ERROR) { + hr = DISP_E_EXCEPTION; + TkWinSend_SetExcepInfo(interp, pExcepInfo); + } + Tcl_Release(interp); + VariantClear(&v); + return hr; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */