--- /dev/null
+/*
+ * 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);
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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);
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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);
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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 */
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * 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;
+}
+\f
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
OSDN Git Service
