* win/makefile.vc: Implementation of TIP #150, "Provide

	* win/tkWinSend.c:    'send' command for Windows"
	* win/tkWinSendCom.h:
	* win/tkWinSendCom.c:

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:
+ */