text: /*
   * 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 © 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,
      };
      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 *comobj,
      VARIANT vCmd,
      VARIANT *pvResult,
      EXCEPINFO *pExcepInfo,
      UINT *puArgErr)
  {
      HRESULT hr = S_OK;
      int result = TCL_OK;
      VARIANT v;
      Tcl_Interp *interp = comobj->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:
   */
  