From 24f20fc73f02098b181de8824060ad93242eddbc Mon Sep 17 00:00:00 2001 From: Pat Thoyts Date: Sun, 31 Mar 2002 00:46:29 +0000 Subject: [PATCH 1/1] Initial revision --- LICENSE | 10 + Makefile | 48 +++++ Readme | 57 ++++++ WinSendCom.c | 236 ++++++++++++++++++++++++ WinSendCom.h | 31 ++++ pkgIndex.tcl | 16 ++ test.vbs | 10 + winsend.c | 506 +++++++++++++++++++++++++++++++++++++++++++++++++++ winsend.def | 3 + winsend.dsp | 131 +++++++++++++ winsend.html | 68 +++++++ 11 files changed, 1116 insertions(+) create mode 100644 LICENSE create mode 100644 Makefile create mode 100644 Readme create mode 100644 WinSendCom.c create mode 100644 WinSendCom.h create mode 100644 pkgIndex.tcl create mode 100644 test.vbs create mode 100644 winsend.c create mode 100644 winsend.def create mode 100644 winsend.dsp create mode 100644 winsend.html diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..9442699 --- /dev/null +++ b/LICENSE @@ -0,0 +1,10 @@ +Copyright (C) 2002 Patrick Thoyts + +Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +Except as contained in this notice, the name of the author shall not be used in advertising or otherwise to promote the sale, use or other dealings in this Software without prior written authorization from the author. + diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..c9cace8 --- /dev/null +++ b/Makefile @@ -0,0 +1,48 @@ +# -*- Makefile -*- +# +# This is a mingw gcc makefile for the winsend package. +# +# Currently: using mingw 1.0 (gcc version 2.95.3) this package +# will not compile due to errors in the headers provided by the +# compiler for the Running Object Table interface. +# +# @(#)$Id$ + +VER =03 +DBGX =d +DBGFLAGS=-D_DEBUG + +CC =gcc -g +DLLWRAP =dllwrap +DLLTOOL =dlltool +RM =rm -f +CFLAGS =-Wall -I/opt/tcl/include -DUSE_TCL_STUBS $(DBGFLAGS) +LDFLAGS =-L/opt/tcl/lib +LIBS =-ltclstub83${DBGX} -lole32 -loleaut32 -ladvapi32 -luuid + +DLL =winsend${VER}${DBGX}.dll +DEFFILE =winsend.def + +WRAPFLAGS =--driver-name $(CC) --def $(DEFFILE) + +CSRCS =winsend.c WinSendCom.c +OBJS =$(CSRCS:.c=.o) + +$(DLL): $(OBJS) + $(DLLWRAP) $(WRAPFLAGS) -o $@ $^ $(LDFLAGS) $(LIBS) + +clean: + $(RM) *.o core *~ + +%.o: %.c + $(CC) $(CFLAGS) -c $< -o $@ + +WinSendCom.o: WinSendCom.c WinSendCom.h + +.PHONY: clean + +# +# Local variables: +# mode: makefile +# End: +# diff --git a/Readme b/Readme new file mode 100644 index 0000000..c1465a6 --- /dev/null +++ b/Readme @@ -0,0 +1,57 @@ +WinSend +------- + +This is a first go at implementing the Tk send command for Tk under MS +Windows using COM to handle the registration and interprocess +communication for us. Briefly this package when loaded into an +interpreter will automatically register the interp in the system's +running object table. The winsend interps command can be used to show +all the registered interpreters and unlike using DDE this command will +not be blocked by badly behaving windows applications. + +An example (from tkcon): from a concurrent tclsh: + % package require winsend | % package require winsend + 0.3 | 0.3 + % winsend interps | % winsend interps + tkcon.tcl | tkcon.tcl TCLSH.EXE + | % winsend send tkcon.tcl set x 1 + | 1 + % set x | + 1 | + % winsend send TCLSH.EXE set y 2 + | % after 2000 {set zx 1} ; vwait zx + 2 | % set y + | 2 + | % exit + % winsend interps | + tkcon.tcl | + +As you can see from the above session - we require an event loop to be +running to handle the incoming send. Technically, this is because we +are using an Apartment threaded object and COM apartments serialize +access to object by using the Windows message queue. A future version +could side-step this by creating a free-threaded object but we are +trying to implement Tk's send here. + +An interesting side-effect is that we can access the running tcl +interpreter from any COM based scripting language. Here is an example +of a VB script file you can run using 'cscript test.vbs' under +windows. It will also work from MS Words macro editor etc. You need to +start up an interpreter and load the winsend package (for instance - +using tkcon): + +Set interp = GetObject("\\.\TclInterp\tkcon.tcl") +interp.Send "puts {Hello from VB Script}" +WScript.Echo interp.Send("info tcl") + +You should see the message printed in your tkcon window and see your +Tcl version printed in your DOS box. + +The code needs tidying up a bit before I publish the source but this +shouldn't take long. In the meantime see + http://tclsoap.sourceforge.net/winsend.html +and + http://tclsoap.sourceforge.net/winsend03.zip +for the docs (this document) and code respectively. + +Pat Thoyts. diff --git a/WinSendCom.c b/WinSendCom.c new file mode 100644 index 0000000..e0167e1 --- /dev/null +++ b/WinSendCom.c @@ -0,0 +1,236 @@ +/* WinSendCom.c - Copyright (C) 2002 Pat Thoyts + * + * 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 interprer. The result is returned as another string. + */ + +static const char rcsid[] = +"$Id$"; + +#include "WinSendCom.h" + +/* ---------------------------------------------------------------------- */ +/* Non-public prototypes. +/* ---------------------------------------------------------------------- */ + +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 HRESULT Send(WinSendCom* obj, VARIANT vCmd, VARIANT* pvResult); + +/* ---------------------------------------------------------------------- */ +/* COM Class Helpers +/* ---------------------------------------------------------------------- */ + +/* Description: + * Create and initialises a new instance of the WinSend COM class and + * returns an interface pointer for you to use. + */ +HRESULT +WinSendCom_CreateInstance(Tcl_Interp *interp, REFIID riid, void **ppv) +{ + static IDispatchVtbl vtbl = { + WinSendCom_QueryInterface, + WinSendCom_AddRef, + WinSendCom_Release, + WinSendCom_GetTypeInfoCount, + WinSendCom_GetTypeInfo, + WinSendCom_GetIDsOfNames, + WinSendCom_Invoke, + }; + HRESULT hr = S_OK; + WinSendCom *obj = NULL; + + obj = (WinSendCom*)malloc(sizeof(WinSendCom)); + if (obj == NULL) { + *ppv = NULL; + hr = E_OUTOFMEMORY; + } else { + obj->lpVtbl = &vtbl; + obj->refcount = 0; + obj->interp = interp; + + /* lock the interp? Tcl_AddRef/Retain? */ + + hr = obj->lpVtbl->QueryInterface((IDispatch*)obj, riid, ppv); + } + + return hr; +} + +/* Description: + * Used to cleanly destroy instances of the CoClass. + */ +void +WinSendCom_Destroy(LPDISPATCH pdisp) +{ + free((void*)pdisp); +} + +/* ---------------------------------------------------------------------- */ + +/* + * WinSendCom IDispatch methods + */ + +static STDMETHODIMP +WinSendCom_QueryInterface(IDispatch *This, + REFIID riid, + void **ppvObject) +{ + HRESULT hr = E_NOINTERFACE; + WinSendCom *this = (WinSendCom*)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; + } + return hr; +} + +static STDMETHODIMP_(ULONG) +WinSendCom_AddRef(IDispatch *This) +{ + WinSendCom *this = (WinSendCom*)This; + return InterlockedIncrement(&this->refcount); +} + +static STDMETHODIMP_(ULONG) +WinSendCom_Release(IDispatch *This) +{ + long r = 0; + WinSendCom *this = (WinSendCom*)This; + if ((r = InterlockedDecrement(&this->refcount)) == 0) { + WinSendCom_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 = 1; + 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; + WinSendCom *this = (WinSendCom*)This; + + switch (dispidMember) + { + case 1: // Send + if (wFlags | DISPATCH_METHOD) + { + if (pDispParams->cArgs != 1) + hr = DISP_E_BADPARAMCOUNT; + else + hr = Send(this, pDispParams->rgvarg[0], pvarResult); + } + } + return hr; +} + +/* Description: + * Evaluates the string in the assigned interpreter. If the result + * is a valid address then set to the result returned by the evaluation. + */ +static HRESULT +Send(WinSendCom* obj, VARIANT vCmd, VARIANT* pvResult) +{ + 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 *script = Tcl_NewUnicodeObj(v.bstrVal, + SysStringLen(v.bstrVal)); + r = Tcl_EvalObjEx(obj->interp, script, TCL_EVAL_DIRECT); + if (pvResult) + { + VariantInit(pvResult); + pvResult->vt = VT_BSTR; + pvResult->bstrVal = SysAllocString(Tcl_GetUnicode(Tcl_GetObjResult(obj->interp))); + } + } + VariantClear(&v); + } + return hr; +} + +/* + * Local Variables: + * mode: c + * indent-tabs-mode: nil + * End: + */ diff --git a/WinSendCom.h b/WinSendCom.h new file mode 100644 index 0000000..efefb8e --- /dev/null +++ b/WinSendCom.h @@ -0,0 +1,31 @@ +/* WinSendCom.h - Copyright (C) 2002 Pat Thoyts + * + * $Id$ + */ + +#include +#include +#include +#include + +/* + * WinSendCom CoClass structure + */ +typedef struct WinSendCom_t { + IDispatchVtbl *lpVtbl; + long refcount; + Tcl_Interp *interp; +} WinSendCom; + +/* + * WinSendCom public methods + */ +HRESULT WinSendCom_CreateInstance(Tcl_Interp *interp, REFIID riid, void **ppv); +void WinSendCom_Destroy(LPDISPATCH pdisp); + +/* + * Local Variables: + * mode: c + * indent-tabs-mode: nil + * End: + */ diff --git a/pkgIndex.tcl b/pkgIndex.tcl new file mode 100644 index 0000000..9efa827 --- /dev/null +++ b/pkgIndex.tcl @@ -0,0 +1,16 @@ +# Tcl package index file, version 1.1 +# This file is generated by the "pkg_mkIndex" command +# and sourced either when an application starts up or +# by a "package unknown" script. It invokes the +# "package ifneeded" command to set up package-related +# information so that packages will be loaded automatically +# in response to "package require" commands. When this +# script is sourced, the variable $dir must contain the +# full path name of this file's directory. + +if {[info exists ::tcl_platform(debug)] && $::tcl_platform(debug)} { + package ifneeded winsend 0.3 [list load [file join $dir winsend03d.dll]] +} else { + package ifneeded winsend 0.3 [list load [file join $dir winsend03.dll]] +} + diff --git a/test.vbs b/test.vbs new file mode 100644 index 0000000..51ac78d --- /dev/null +++ b/test.vbs @@ -0,0 +1,10 @@ +Dim o +Set o = GetObject("\\.\TclInterp\tkcon.tcl") +WScript.Echo o.Send("puts {Hello, from VB} ; tkcon master wm title .") + +Dim p +Set p = GetObject("\\.\TclInterp\tkcon.tcl #2") +WScript.Echo p.Send("puts {Hello, 2}; tkcon master wm title .") + + + diff --git a/winsend.c b/winsend.c new file mode 100644 index 0000000..ba58467 --- /dev/null +++ b/winsend.c @@ -0,0 +1,506 @@ +/* winsend.c - Copyright (C) 2002 Pat Thoyts + */ + +/* + * TODO: + * Put the ROT cookie into a client data structure. + * Use a C based COM object. + * Arrange to register the dispinterface ID? + * Check the tkWinSend.c file and implement a Tk send. + */ + +static const char rcsid[] = +"$Id$"; + +#include +#include +#include +#include + +#include +#include "WinSendCom.h" + +#ifndef DECLSPEC_EXPORT +#define DECLSPEC_EXPORT __declspec(dllexport) +#endif /* ! DECLSPEC_EXPORT */ + +/* Should be defined in WTypes.h but mingw 1.0 is missing them */ +#ifndef _ROTFLAGS_DEFINED +#define ROTFLAGS_REGISTRATIONKEEPSALIVE 0x01 +#define ROTFLAGS_ALLOWANYCLIENT 0x02 +#endif /* ! _ROTFLAGS_DEFINED */ + +#define WINSEND_PACKAGE_VERSION "0.3" +#define WINSEND_PACKAGE_NAME "winsend" +#define WINSEND_CLASS_NAME "TclEval" + +DWORD g_dwROTCookie; + +static void Winsend_PkgDeleteProc _ANSI_ARGS_((ClientData clientData)); +static int Winsend_CmdProc(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +static int Winsend_CmdInterps(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +static int Winsend_CmdSend(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +static int Winsend_CmdTest(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +static int Winsend_ObjSendCmd(LPDISPATCH pdispInterp, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]); +static HRESULT BuildMoniker(LPCOLESTR name, LPMONIKER *pmk); +static Tcl_Obj* Winsend_Win32ErrorObj(HRESULT hrError); + +// ------------------------------------------------------------------------- +// DllMain +// ------------------------------------------------------------------------- + +EXTERN_C BOOL APIENTRY +DllMain(HANDLE hModule, DWORD dwReason, LPVOID lpReserved) +{ + switch(dwReason) + { + case DLL_PROCESS_ATTACH: + break; + case DLL_PROCESS_DETACH: + break; + } + + return TRUE; +} + +// ------------------------------------------------------------------------- +// Winsend_Init +// ------------------------------------------------------------------------- + +EXTERN_C int DECLSPEC_EXPORT +Winsend_Init(Tcl_Interp* interp) +{ + HRESULT hr = S_OK; + int r = TCL_OK; + IUnknown *pUnk = NULL; + +#ifdef USE_TCL_STUBS + Tcl_InitStubs(interp, "8.3", 0); +#endif + + // Initialize COM + hr = CoInitialize(0); + if (FAILED(hr)) { + Tcl_SetResult(interp, "failed to initialize the " WINSEND_PACKAGE_NAME " package", TCL_STATIC); + return TCL_ERROR; + } + + // Create our registration object. + hr = WinSendCom_CreateInstance(interp, &IID_IUnknown, (void**)&pUnk); + + if (SUCCEEDED(hr)) + { + LPRUNNINGOBJECTTABLE pROT = NULL; + Tcl_Obj *name = NULL; + + if (Tcl_Eval(interp, "file tail $::argv0") == TCL_OK) + name = Tcl_GetObjResult(interp); + if (name == NULL) + name = Tcl_NewUnicodeObj(L"tcl", 3); + + hr = GetRunningObjectTable(0, &pROT); + if (SUCCEEDED(hr)) + { + int n = 1; + LPMONIKER pmk = NULL; + OLECHAR oleName[64]; + oleName[0] = 0; + + do + { + if (n > 1) + swprintf(oleName, L"%s #%u", Tcl_GetUnicode(name), n); + else + wcscpy(oleName, Tcl_GetUnicode(name)); + n++; + + hr = BuildMoniker(oleName, &pmk); + + if (SUCCEEDED(hr)) { + hr = pROT->lpVtbl->Register(pROT, + ROTFLAGS_REGISTRATIONKEEPSALIVE + | ROTFLAGS_ALLOWANYCLIENT, + pUnk, pmk, &g_dwROTCookie); + pmk->lpVtbl->Release(pmk); + } + + /* If the moniker was registered, unregister the duplicate and + * try again. + */ + if (hr == MK_S_MONIKERALREADYREGISTERED) + pROT->lpVtbl->Revoke(pROT, g_dwROTCookie); + + } while (hr == MK_S_MONIKERALREADYREGISTERED); + + pROT->lpVtbl->Release(pROT); + } + + pUnk->lpVtbl->Release(pUnk); + + // Create our winsend command + if (SUCCEEDED(hr)) { + Tcl_CreateObjCommand(interp, "winsend", Winsend_CmdProc, (ClientData)0, (Tcl_CmdDeleteProc*)0); + } + + /* Create an exit procedure to handle unregistering when the + * Tcl interpreter terminates. + */ + Tcl_CreateExitHandler(Winsend_PkgDeleteProc, NULL); + r = Tcl_PkgProvide(interp, WINSEND_PACKAGE_NAME, WINSEND_PACKAGE_VERSION); + + } + if (FAILED(hr)) + { + // TODO: better error handling - rip code from w32_exception.h + Tcl_Obj *err = Winsend_Win32ErrorObj(hr); + Tcl_SetObjResult(interp, err); + r = TCL_ERROR; + } else { + Tcl_SetResult(interp, "", TCL_STATIC); + } + + return r; +} + +// ------------------------------------------------------------------------- +// Winsend_SafeInit +// ------------------------------------------------------------------------- + +EXTERN_C int DECLSPEC_EXPORT +Winsend_SafeInit(Tcl_Interp* interp) +{ + Tcl_SetResult(interp, "not permitted in safe interp", TCL_STATIC); + return TCL_ERROR; +} + +// ------------------------------------------------------------------------- +// WinsendExitProc +// ------------------------------------------------------------------------- + +static void +Winsend_PkgDeleteProc(ClientData clientData) +{ + LPRUNNINGOBJECTTABLE pROT = NULL; + HRESULT hr = GetRunningObjectTable(0, &pROT); + if (SUCCEEDED(hr)) + { + hr = pROT->lpVtbl->Revoke(pROT, g_dwROTCookie); + pROT->lpVtbl->Release(pROT); + } + //ASSERT +} + +// ------------------------------------------------------------------------- +// Winsend_CmdProc +// ------------------------------------------------------------------------- + +static int +Winsend_CmdProc(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]) +{ + enum {WINSEND_INTERPS, WINSEND_SEND, WINSEND_TEST}; + static char* cmds[] = { "interps", "send", "test", NULL }; + int index = 0, r = TCL_OK; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "command ?args ...?"); + return TCL_ERROR; + } + + r = Tcl_GetIndexFromObj(interp, objv[1], cmds, "command", 0, &index); + if (r == TCL_OK) + { + switch (index) + { + case WINSEND_INTERPS: + r = Winsend_CmdInterps(clientData, interp, objc, objv); + break; + case WINSEND_SEND: + r = Winsend_CmdSend(clientData, interp, objc, objv); + break; + case WINSEND_TEST: + r = Winsend_CmdTest(clientData, interp, objc, objv); + break; + } + } + return r; +} + +// ------------------------------------------------------------------------- +// Winsend_CmdInterps +// ------------------------------------------------------------------------- + +static int +Winsend_CmdInterps(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]) +{ + LPRUNNINGOBJECTTABLE pROT = NULL; + LPCOLESTR oleszStub = OLESTR("\\\\.\\TclInterp"); + HRESULT hr = S_OK; + Tcl_Obj *objList; + int r = TCL_OK; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "interps"); + r = TCL_ERROR; + } else { + + hr = GetRunningObjectTable(0, &pROT); + if(SUCCEEDED(hr)) + { + IBindCtx* pBindCtx = NULL; + objList = Tcl_NewListObj(0, NULL); + hr = CreateBindCtx(0, &pBindCtx); + if (SUCCEEDED(hr)) + { + + IEnumMoniker* pEnum; + hr = pROT->lpVtbl->EnumRunning(pROT, &pEnum); + if(SUCCEEDED(hr)) + { + IMoniker* pmk = NULL; + while (pEnum->lpVtbl->Next(pEnum, 1, &pmk, (ULONG*)NULL) == S_OK) + { + LPOLESTR olestr; + hr = pmk->lpVtbl->GetDisplayName(pmk, pBindCtx, NULL, &olestr); + if (SUCCEEDED(hr)) + { + IMalloc *pMalloc = NULL; + + if (wcsncmp(olestr, oleszStub, wcslen(oleszStub)) == 0) + { + LPOLESTR p = olestr + wcslen(oleszStub) + 1; + r = Tcl_ListObjAppendElement(interp, objList, Tcl_NewUnicodeObj(p, -1)); + } + + hr = CoGetMalloc(1, &pMalloc); + if (SUCCEEDED(hr)) + { + pMalloc->lpVtbl->Free(pMalloc, (void*)olestr); + pMalloc->lpVtbl->Release(pMalloc); + } + } + pmk->lpVtbl->Release(pmk); + } + pEnum->lpVtbl->Release(pEnum); + } + pBindCtx->lpVtbl->Release(pBindCtx); + } + pROT->lpVtbl->Release(pROT); + } + } + + if (FAILED(hr)) { + /* expire the list if set */ + if (objList != NULL) { + Tcl_DecrRefCount(objList); + } + Tcl_SetObjResult(interp, Winsend_Win32ErrorObj(hr)); + r = TCL_ERROR; + } + + if (r == TCL_OK) + Tcl_SetObjResult(interp, objList); + + return r; +} + +// ------------------------------------------------------------------------- +// Winsend_CmdSend +// ------------------------------------------------------------------------- + +static int +Winsend_CmdSend(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]) +{ + int r = TCL_OK; + HRESULT hr = S_OK; + + if (objc < 4) { + + Tcl_WrongNumArgs(interp, 1, objv, "app cmd ?arg arg arg?"); + r = TCL_ERROR; + + } else { + + LPRUNNINGOBJECTTABLE pROT = NULL; + + hr = GetRunningObjectTable(0, &pROT); + if (SUCCEEDED(hr)) + { + IBindCtx* pBindCtx = NULL; + hr = CreateBindCtx(0, &pBindCtx); + if (SUCCEEDED(hr)) + { + LPMONIKER pmk = NULL; + hr = BuildMoniker(Tcl_GetUnicode(objv[2]), &pmk); + if (SUCCEEDED(hr)) + { + IUnknown* punkInterp = NULL; + IDispatch* pdispInterp = NULL; + hr = pROT->lpVtbl->IsRunning(pROT, pmk); + hr = pmk->lpVtbl->BindToObject(pmk, pBindCtx, NULL, &IID_IUnknown, (void**)&punkInterp); + //hr = pROT->lpVtbl->GetObject(pROT, pmk, &punkInterp); + if (SUCCEEDED(hr)) + hr = punkInterp->lpVtbl->QueryInterface(punkInterp, &IID_IDispatch, (void**)&pdispInterp); + if (SUCCEEDED(hr)) + { + r = Winsend_ObjSendCmd(pdispInterp, interp, objc, objv); + pdispInterp->lpVtbl->Release(pdispInterp); + punkInterp->lpVtbl->Release(punkInterp); + } + pmk->lpVtbl->Release(pmk); + } + pBindCtx->lpVtbl->Release(pBindCtx); + } + pROT->lpVtbl->Release(pROT); + } + if (FAILED(hr)) + { + Tcl_SetObjResult(interp, Winsend_Win32ErrorObj(hr)); + r = TCL_ERROR; + } + } + + return r; +} + +/* ------------------------------------------------------------------------- + * Winsend_CmdTest + * ------------------------------------------------------------------------- + */ +static int +Winsend_CmdTest(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]) +{ + enum {WINSEND_TEST_ERROR}; + static char* cmds[] = { "error", NULL }; + int index = 0, r = TCL_OK; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "command ?args ...?"); + return TCL_ERROR; + } + + r = Tcl_GetIndexFromObj(interp, objv[2], cmds, "command", 0, &index); + if (r == TCL_OK) + { + switch (index) + { + case WINSEND_TEST_ERROR: + { + Tcl_Obj *err = Winsend_Win32ErrorObj(E_INVALIDARG); + Tcl_SetObjResult(interp, err); + r = TCL_ERROR; + } + break; + } + } + return r; +} + +// ------------------------------------------------------------------------- +// Helpers. +// ------------------------------------------------------------------------- + +// ------------------------------------------------------------------------- +// Winsend_ObjSendCmd +// ------------------------------------------------------------------------- +// Description: +// +static int +Winsend_ObjSendCmd(LPDISPATCH pdispInterp, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[]) +{ + VARIANT vCmd, vResult; + DISPPARAMS dp; + EXCEPINFO ei; + UINT uiErr = 0; + HRESULT hr = S_OK; + Tcl_Obj *cmd = NULL; + + cmd = Tcl_ConcatObj(objc - 3, &objv[3]); + + VariantInit(&vCmd); + VariantInit(&vResult); + memset(&dp, 0, sizeof(dp)); + memset(&ei, 0, sizeof(ei)); + + vCmd.vt = VT_BSTR; + vCmd.bstrVal = SysAllocString(Tcl_GetUnicode(cmd)); + + dp.cArgs = 1; + dp.rgvarg = &vCmd; + + hr = pdispInterp->lpVtbl->Invoke(pdispInterp, 1, &IID_NULL, LOCALE_SYSTEM_DEFAULT, DISPATCH_METHOD, &dp, &vResult, &ei, &uiErr); + if (SUCCEEDED(hr)) + { + hr = VariantChangeType(&vResult, &vResult, 0, VT_BSTR); + if (SUCCEEDED(hr)) + Tcl_SetObjResult(interp, Tcl_NewUnicodeObj(vResult.bstrVal, -1)); + } + + VariantClear(&vCmd); + + return (SUCCEEDED(hr) ? TCL_OK : TCL_ERROR); +} + +// Construct a Tcl interpreter moniker from an interp name. +static HRESULT +BuildMoniker(LPCOLESTR name, LPMONIKER *pmk) +{ + LPCOLESTR oleszStub = OLESTR("\\\\.\\TclInterp"); + LPMONIKER pmkClass = NULL; + HRESULT hr = CreateFileMoniker(oleszStub, &pmkClass); + if (SUCCEEDED(hr)) { + LPMONIKER pmkItem = NULL; + hr = CreateFileMoniker(name, &pmkItem); + if (SUCCEEDED(hr)) { + LPMONIKER pmkJoint = NULL; + hr = pmkClass->lpVtbl->ComposeWith(pmkClass, pmkItem, FALSE, &pmkJoint); + if (SUCCEEDED(hr)) { + *pmk = pmkJoint; + (*pmk)->lpVtbl->AddRef(*pmk); + pmkJoint->lpVtbl->Release(pmkJoint); + } + pmkItem->lpVtbl->Release(pmkItem); + } + pmkClass->lpVtbl->Release(pmkClass); + } + return hr; +} + +static Tcl_Obj* +Winsend_Win32ErrorObj(HRESULT hrError) +{ + LPTSTR lpBuffer = NULL, p = NULL; + TCHAR sBuffer[30]; + Tcl_Obj* err_obj = NULL; + + FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER | FORMAT_MESSAGE_FROM_SYSTEM, + NULL, hrError, LANG_NEUTRAL, (LPTSTR)&lpBuffer, 0, NULL); + + if (lpBuffer == NULL) { + lpBuffer = sBuffer; + wsprintf(sBuffer, _T("Error Code: %08lX"), hrError); + } + + if ((p = _tcsrchr(lpBuffer, _T('\r'))) != NULL) + *p = _T('\0'); + +#ifdef _UNICODE + err_obj = Tcl_NewUnicodeObj(lpBuffer, wcslen(lpBuffer)); +#else + err_obj = Tcl_NewStringObj(lpBuffer, strlen(lpBuffer)); +#endif + + if (lpBuffer != sBuffer) + LocalFree((HLOCAL)lpBuffer); + + return err_obj; +} diff --git a/winsend.def b/winsend.def new file mode 100644 index 0000000..4913eff --- /dev/null +++ b/winsend.def @@ -0,0 +1,3 @@ +EXPORTS +Winsend_Init +Winsend_SafeInit diff --git a/winsend.dsp b/winsend.dsp new file mode 100644 index 0000000..36bb995 --- /dev/null +++ b/winsend.dsp @@ -0,0 +1,131 @@ +# Microsoft Developer Studio Project File - Name="winsend" - Package Owner=<4> +# Microsoft Developer Studio Generated Build File, Format Version 6.00 +# ** DO NOT EDIT ** + +# TARGTYPE "Win32 (x86) Dynamic-Link Library" 0x0102 + +CFG=winsend - Win32 Debug +!MESSAGE This is not a valid makefile. To build this project using NMAKE, +!MESSAGE use the Export Makefile command and run +!MESSAGE +!MESSAGE NMAKE /f "winsend.mak". +!MESSAGE +!MESSAGE You can specify a configuration when running NMAKE +!MESSAGE by defining the macro CFG on the command line. For example: +!MESSAGE +!MESSAGE NMAKE /f "winsend.mak" CFG="winsend - Win32 Debug" +!MESSAGE +!MESSAGE Possible choices for configuration are: +!MESSAGE +!MESSAGE "winsend - Win32 Release" (based on "Win32 (x86) Dynamic-Link Library") +!MESSAGE "winsend - Win32 Debug" (based on "Win32 (x86) Dynamic-Link Library") +!MESSAGE + +# Begin Project +# PROP AllowPerConfigDependencies 0 +# PROP Scc_ProjName "" +# PROP Scc_LocalPath "" +CPP=cl.exe +MTL=midl.exe +RSC=rc.exe + +!IF "$(CFG)" == "winsend - Win32 Release" + +# PROP BASE Use_MFC 0 +# PROP BASE Use_Debug_Libraries 0 +# PROP BASE Output_Dir "Release" +# PROP BASE Intermediate_Dir "Release" +# PROP BASE Target_Dir "" +# PROP Use_MFC 0 +# PROP Use_Debug_Libraries 0 +# PROP Output_Dir "Release" +# PROP Intermediate_Dir "Release" +# PROP Ignore_Export_Lib 0 +# PROP Target_Dir "" +# ADD BASE CPP /nologo /MT /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "WINSEND_EXPORTS" /YX /FD /c +# ADD CPP /nologo /MT /W3 /GX /O2 /D "NDEBUG" /D "WIN32" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "WINSEND_EXPORTS" /D "USE_TCL_STUBS" /YX /FD /c +# ADD BASE MTL /nologo /D "NDEBUG" /mktyplib203 /win32 +# ADD MTL /nologo /D "NDEBUG" /mktyplib203 /win32 +# ADD BASE RSC /l 0x809 /d "NDEBUG" +# ADD RSC /l 0x809 /d "NDEBUG" +BSC32=bscmake.exe +# ADD BASE BSC32 /nologo +# ADD BSC32 /nologo +LINK32=link.exe +# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /machine:I386 +# ADD LINK32 tclstub83.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /machine:I386 /out:"winsend03.dll" + +!ELSEIF "$(CFG)" == "winsend - Win32 Debug" + +# PROP BASE Use_MFC 0 +# PROP BASE Use_Debug_Libraries 1 +# PROP BASE Output_Dir "Debug" +# PROP BASE Intermediate_Dir "Debug" +# PROP BASE Target_Dir "" +# PROP Use_MFC 0 +# PROP Use_Debug_Libraries 1 +# PROP Output_Dir "Debug" +# PROP Intermediate_Dir "Debug" +# PROP Ignore_Export_Lib 0 +# PROP Target_Dir "" +# ADD BASE CPP /nologo /MTd /W3 /Gm /GX /ZI /Od /D "WIN32" /D "_DEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "WINSEND_EXPORTS" /YX /FD /GZ /c +# ADD CPP /nologo /MTd /W3 /Gm /GX /ZI /Od /D "_DEBUG" /D "WIN32" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "WINSEND_EXPORTS" /D "USE_TCL_STUBS" /YX /FD /GZ /c +# ADD BASE MTL /nologo /D "_DEBUG" /mktyplib203 /win32 +# ADD MTL /nologo /D "_DEBUG" /mktyplib203 /win32 +# ADD BASE RSC /l 0x809 /d "_DEBUG" +# ADD RSC /l 0x809 /d "_DEBUG" +BSC32=bscmake.exe +# ADD BASE BSC32 /nologo +# ADD BSC32 /nologo +LINK32=link.exe +# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /debug /machine:I386 /pdbtype:sept +# ADD LINK32 tclstub83d.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /debug /machine:I386 /out:"winsend03d.dll" /pdbtype:sept + +!ENDIF + +# Begin Target + +# Name "winsend - Win32 Release" +# Name "winsend - Win32 Debug" +# Begin Group "Source Files" + +# PROP Default_Filter "cpp;c;cxx;rc;def;r;odl;idl;hpj;bat" +# Begin Source File + +SOURCE=.\winsend.c +# End Source File +# Begin Source File + +SOURCE=.\winsend.def +# End Source File +# Begin Source File + +SOURCE=.\WinSendCom.c +# End Source File +# End Group +# Begin Group "Header Files" + +# PROP Default_Filter "h;hpp;hxx;hm;inl" +# Begin Source File + +SOURCE=.\WinSendCom.h +# End Source File +# End Group +# Begin Group "Resource Files" + +# PROP Default_Filter "ico;cur;bmp;dlg;rc2;rct;bin;rgs;gif;jpg;jpeg;jpe" +# End Group +# Begin Source File + +SOURCE=.\Readme +# End Source File +# Begin Source File + +SOURCE=.\test.vbs +# End Source File +# Begin Source File + +SOURCE=.\winsend.html +# End Source File +# End Target +# End Project diff --git a/winsend.html b/winsend.html new file mode 100644 index 0000000..e5376fe --- /dev/null +++ b/winsend.html @@ -0,0 +1,68 @@ + + + +WinSend 0.3 + + + + +

WinSend - A COM Implementation of the Tk Send Command.

+ +

This is a first go at implementing the Tk send command for +Tk under MS Windows using COM to handle the registration and +interprocess communication for us. Briefly this package when loaded +into an interpreter will automatically register the interp in the +system's running object table. The winsend interps command +can be used to show all the registered interpreters and unlike using +DDE this command will not be blocked by badly behaving windows +applications.

+ +
+An example (from tkcon):         from a concurrent tclsh:
+  % package require winsend  |     % package require winsend
+  0.3                        |     0.3
+  % winsend interps          |     % winsend interps
+  tkcon.tcl                  |     tkcon.tcl TCLSH.EXE
+                             |     % winsend send tkcon.tcl set x 1
+                             |     1
+  % set x                    |
+  1                          |
+  % winsend send TCLSH.EXE set y 2
+                             |     % after 2000 {set zx 1} ; vwait zx
+  2                          |     % set y
+                             |     2
+                             |     % exit
+  % winsend interps          |
+  tkcon.tcl                  |
+
+ +

As you can see from the above session - we require an event loop to be +running to handle the incoming send. Technically, this is because we +are using an Apartment threaded object and COM apartments serialize +access to object by using the Windows message queue. A future version +could side-step this by creating a free-threaded object but we are +trying to implement Tk's send here.

+ +

An interesting side-effect is that we can access the running Tcl +interpreter from any COM using scripting language. Here is an example +of a VB script file you can run using cscript test.vbs under +windows. It will also work from MS Words macro editor etc. You need to +start up an interpreter and load the winsend package (for instance - +using tkcon):

+ +
Set interp = GetObject("\\.\TclInterp\tkcon.tcl")
+interp.Send "puts {Hello from VB Script}"
+WScript.Echo interp.Send("info tcl")
+ +

You should see the message printed in your tkcon window and see your +Tcl version printed in your DOS box.

+ +

The package containing binaries and source is available from + +http://tclsoap.sf.net/winsend03.zip

+ +

Pat Thoyts.

+ + + + -- 2.23.0