summaryrefslogtreecommitdiffstats
path: root/win/tkWinSendCom.c
diff options
context:
space:
mode:
Diffstat (limited to 'win/tkWinSendCom.c')
-rw-r--r--win/tkWinSendCom.c462
1 files changed, 462 insertions, 0 deletions
diff --git a/win/tkWinSendCom.c b/win/tkWinSendCom.c
new file mode 100644
index 0000000..3bbdd63
--- /dev/null
+++ b/win/tkWinSendCom.c
@@ -0,0 +1,462 @@
+/*
+ * 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_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));
+ 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:
+ */
generated by cgit v0.12 at 2024-11-08 14:31:41 (GMT)