From 26550c5ff2036d44db25d0b6799565cff27ecf33 Mon Sep 17 00:00:00 2001 From: Pat Thoyts Date: Mon, 3 Dec 2007 09:07:16 +0000 Subject: [PATCH] Imported the cmdName type reference object technique from tcom to handle the com object commands. Lots of refactoring. --- configure | 20 +-- configure.in | 4 +- src/invoke.c | 194 ++++++++++++++++++++++++ src/oleobj.c | 176 ++++++++++++++++++++++ src/tclole.c | 385 ++++++++++++++++++------------------------------ src/tcloleInt.h | 62 +++++++- src/util.c | 14 ++ src/varobj.c | 147 ++++++++++++++++++ win/makefile.vc | 7 +- 9 files changed, 750 insertions(+), 259 deletions(-) create mode 100644 src/invoke.c create mode 100644 src/oleobj.c create mode 100644 src/varobj.c diff --git a/configure b/configure index dbee733..c0b7542 100755 --- a/configure +++ b/configure @@ -1,6 +1,6 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.59 for tclole 0.1. +# Generated by GNU Autoconf 2.59 for tclole 0.2. # # Copyright (C) 2003 Free Software Foundation, Inc. # This configure script is free software; the Free Software Foundation @@ -267,8 +267,8 @@ SHELL=${CONFIG_SHELL-/bin/sh} # Identity of this package. PACKAGE_NAME='tclole' PACKAGE_TARNAME='tclole' -PACKAGE_VERSION='0.1' -PACKAGE_STRING='tclole 0.1' +PACKAGE_VERSION='0.2' +PACKAGE_STRING='tclole 0.2' PACKAGE_BUGREPORT='' # Factoring default headers for most tests. @@ -777,7 +777,7 @@ if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF -\`configure' configures tclole 0.1 to adapt to many kinds of systems. +\`configure' configures tclole 0.2 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... @@ -834,7 +834,7 @@ fi if test -n "$ac_init_help"; then case $ac_init_help in - short | recursive ) echo "Configuration of tclole 0.1:";; + short | recursive ) echo "Configuration of tclole 0.2:";; esac cat <<\_ACEOF @@ -966,7 +966,7 @@ fi test -n "$ac_init_help" && exit 0 if $ac_init_version; then cat <<\_ACEOF -tclole configure 0.1 +tclole configure 0.2 generated by GNU Autoconf 2.59 Copyright (C) 2003 Free Software Foundation, Inc. @@ -980,7 +980,7 @@ cat >&5 <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. -It was created by tclole $as_me 0.1, which was +It was created by tclole $as_me 0.2, which was generated by GNU Autoconf 2.59. Invocation command line was $ $0 $@ @@ -6133,7 +6133,7 @@ done #----------------------------------------------------------------------- - vars="src/tclole.c src/util.c" + vars="src/tclole.c src/invoke.c src/oleobj.c src/varobj.c src/util.c" for i in $vars; do case $i in \$*) @@ -10733,7 +10733,7 @@ _ASBOX } >&5 cat >&5 <<_CSEOF -This file was extended by tclole $as_me 0.1, which was +This file was extended by tclole $as_me 0.2, which was generated by GNU Autoconf 2.59. Invocation command line was CONFIG_FILES = $CONFIG_FILES @@ -10788,7 +10788,7 @@ _ACEOF cat >>$CONFIG_STATUS <<_ACEOF ac_cs_version="\\ -tclole config.status 0.1 +tclole config.status 0.2 configured by $0, generated by GNU Autoconf 2.59, with options \\"`echo "$ac_configure_args" | sed 's/[\\""\`\$]/\\\\&/g'`\\" diff --git a/configure.in b/configure.in index d6246de..a6c8655 100644 --- a/configure.in +++ b/configure.in @@ -19,7 +19,7 @@ dnl to configure the system for the local environment. # so you can encode the package version directly into the source files. #----------------------------------------------------------------------- -AC_INIT([tclole], [0.1]) +AC_INIT([tclole], [0.2]) #-------------------------------------------------------------------- # Call TEA_INIT as the first TEA_ macro to set up initial vars. @@ -71,7 +71,7 @@ TEA_SETUP_COMPILER # and PKG_TCL_SOURCES. #----------------------------------------------------------------------- -TEA_ADD_SOURCES([src/tclole.c src/util.c]) +TEA_ADD_SOURCES([src/tclole.c src/invoke.c src/oleobj.c src/varobj.c src/util.c]) TEA_ADD_HEADERS([src/tclole.h]) TEA_ADD_INCLUDES([-I. -I\"`${CYGPATH} ${srcdir}/src`\"]) TEA_ADD_LIBS([]) diff --git a/src/invoke.c b/src/invoke.c new file mode 100644 index 0000000..edd6869 --- /dev/null +++ b/src/invoke.c @@ -0,0 +1,194 @@ +/* invoke.c - Copyright (C) 2007 Pat Thoyts + * + * Minimal COM Automation package + * + * See the file "LICENSE" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * $Id$ + */ + +#include "tcloleInt.h" + +static HRESULT +OleVariantObj(Tcl_Interp *interp, VARIANT v, Tcl_Obj **resultPtrPtr) +{ + HRESULT hr = S_OK; + + /* + * FIX ME: Needs to handle VT_ARRAY and VT_BYREF flags + */ + + switch (v.vt) { + case VT_BOOL: + *resultPtrPtr = Tcl_NewBooleanObj((v.boolVal != VARIANT_FALSE)); + break; + case VT_I2: + *resultPtrPtr = Tcl_NewIntObj(v.iVal); + break; + case VT_I4: + *resultPtrPtr = Tcl_NewLongObj(v.lVal); + break; + case VT_R4: + *resultPtrPtr = Tcl_NewDoubleObj(v.fltVal); + break; + case VT_R8: + *resultPtrPtr = Tcl_NewDoubleObj(v.dblVal); + break; + case VT_UNKNOWN: + hr = VariantChangeType(&v, &v, 0, VT_DISPATCH); + if (SUCCEEDED(hr)) + *resultPtrPtr = Ole_NewOleObj(interp, v.pdispVal); + break; + case VT_DISPATCH: + *resultPtrPtr = Ole_NewOleObj(interp, v.pdispVal); + break; + case VT_CY: case VT_DATE: case VT_DECIMAL: + case VT_VARIANT: + /* *resultPtrPtr = Ole_NewVariantObj(v);*/ + /* break; */ + default: { + hr = VariantChangeType(&v, &v, VARIANT_ALPHABOOL, VT_BSTR); + if (SUCCEEDED(hr)) + *resultPtrPtr = Tcl_NewUnicodeObj(v.bstrVal, -1); + } + } + return hr; +} + +static DISPPARAMS * +OleDispParamsCreate(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) +{ + OlePackageData *pkgPtr; + DISPPARAMS * dp; + int cn; + + pkgPtr = Tcl_GetAssocData(interp, "ole::package", NULL); + + dp = (DISPPARAMS*)ckalloc(sizeof(DISPPARAMS)); + if (dp != NULL) { + dp->cArgs = objc; + dp->cNamedArgs = 0; + dp->rgdispidNamedArgs = NULL; + dp->rgvarg = NULL; + if (objc > 0) { + dp->rgvarg = (VARIANT*)ckalloc(sizeof(VARIANT) * dp->cArgs); + } + + /* Note: this array is filled backwards */ + for (cn = 0; cn < objc; cn++) { + Tcl_Obj *objPtr = objv[objc - cn - 1]; + Tcl_ObjType *typePtr = NULL; + VARIANT *argPtr = &dp->rgvarg[cn]; + + VariantInit(argPtr); + if (objPtr->typePtr != NULL) { + if (objPtr->typePtr == tclTypes[tclBooleanType]) { + int b; + Tcl_GetBooleanFromObj(NULL, objPtr, &b); + argPtr->boolVal = (b ? VARIANT_TRUE : VARIANT_FALSE); + argPtr->vt = VT_BOOL; + } else if (objPtr->typePtr == tclTypes[tclIntegerType]) { + Tcl_GetLongFromObj(NULL, objPtr, &argPtr->lVal); + argPtr->vt = VT_I4; + } else if (objPtr->typePtr == tclTypes[tclDoubleType]) { + Tcl_GetDoubleFromObj(NULL, objPtr, &argPtr->dblVal); + argPtr->vt = VT_R8; + } else if (objPtr->typePtr == &tclVariantType) { + VariantCopy(argPtr, GET_VARIANTREP(objPtr)); + argPtr->vt = VT_VARIANT; + } + } + if (argPtr->vt == VT_EMPTY) { + LPCOLESTR olestr = Tcl_GetUnicode(objPtr); + argPtr->bstrVal = SysAllocString(olestr); + argPtr->vt = VT_BSTR; + } + } + } + return dp; +} + +static void +OleDispParamsFree(DISPPARAMS *dp) +{ + VARIANT *pv = dp->rgvarg; + size_t n; + for (n = 0; n < dp->cArgs; n++, pv++) { + VariantClear(pv); + } + ckfree((void *)dp->rgvarg); + ckfree((void *)dp); +} + +int +OleObjectInvoke(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +{ + OleObjectData *dataPtr = clientData; + HRESULT hr; + DISPID dispid; + LPWSTR name; + WORD mode = DISPATCH_PROPERTYGET | DISPATCH_METHOD; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name ?arg ...?"); + return TCL_ERROR; + } + + name = Tcl_GetUnicode(objv[1]); + if (dataPtr->typeinfoPtr) { + hr = dataPtr->typeinfoPtr->lpVtbl->GetIDsOfNames(dataPtr->typeinfoPtr, + &name, 1, (MEMBERID *)&dispid); + } else { + hr = dataPtr->dispatchPtr->lpVtbl->GetIDsOfNames(dataPtr->dispatchPtr, + &IID_NULL, &name, 1, LOCALE_SYSTEM_DEFAULT, &dispid); + } + if (SUCCEEDED(hr)) + { + VARIANT v; + EXCEPINFO ei; + DISPPARAMS *dp = NULL; + UINT uierr; + + VariantInit(&v); + dp = OleDispParamsCreate(interp, objc-2, objv+2); + + if ((mode & DISPATCH_PROPERTYPUT) || (mode & DISPATCH_PROPERTYPUTREF)) { + static DISPID putid = DISPID_PROPERTYPUT; + dp->rgdispidNamedArgs = &putid; + dp->cNamedArgs = 1; + } + + if (dataPtr->typeinfoPtr) { + hr = dataPtr->typeinfoPtr->lpVtbl->Invoke(dataPtr->typeinfoPtr, + dataPtr->dispatchPtr, (MEMBERID)dispid, mode, dp, + &v, &ei, &uierr); + } else { + hr = dataPtr->dispatchPtr->lpVtbl->Invoke(dataPtr->dispatchPtr, + dispid, &IID_NULL, LOCALE_SYSTEM_DEFAULT, mode, dp, &v, &ei, + &uierr); + } + OleDispParamsFree(dp); + if (SUCCEEDED(hr)) { + Tcl_Obj *resultObj = Ole_NewVariantObj(v); + hr = OleVariantObj(interp, v, &resultObj); + if (SUCCEEDED(hr)) { + Tcl_SetObjResult(interp, resultObj); + } + } + VariantClear(&v); + } + if (FAILED(hr)) { + Tcl_SetObjResult(interp, Ole_Win32ErrorObj(interp, "invoke", hr)); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + * Local variables: + * indent-tabs-mode: t + * tab-width: 8 + * End: + */ diff --git a/src/oleobj.c b/src/oleobj.c new file mode 100644 index 0000000..764b2f0 --- /dev/null +++ b/src/oleobj.c @@ -0,0 +1,176 @@ +/* oleobj.c - Copyright (C) 2007 Pat Thoyts + * + * Minimal COM Automation package + * + * See the file "LICENSE" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * $Id$ + */ + +/* + * We need to be able to create a Jim reference. That is some variable + * that is executable. In 8.5 we have a lambda type that should be ok + * for this if it is callable from C. For < 8.5 we must likely use either + * tcom's method which overloads the tcl cmdName type to create a tclobj + * that decrements references to the ole reference. Or we can do it the + * crappy way and require explicit destruction. + */ + +#include "tcloleInt.h" + +static void OleObjectDelete(ClientData clientData); + +static void CmdFreeProc(Tcl_Obj *objPtr); +static void CmdDupProc(Tcl_Obj *objPtr, Tcl_Obj *dupPtr); +static int CmdSetProc(Tcl_Interp *interp, Tcl_Obj *objPtr); + +#define GET_OLEREP(objPtr) \ + ((OleObjectData *)(objPtr)->internalRep.twoPtrValue.ptr2) +#define SET_OLEREP(objPtr, dataPtr) \ + (objPtr)->internalRep.twoPtrValue.ptr2 = (void *)(dataPtr) + +static Tcl_ObjType tclCmdNameType; +static Tcl_ObjType *tclCmdNameTypePtr; + +/* + * OLE Command object function -- + */ + +static void +CmdFreeProc(Tcl_Obj *objPtr) +{ + OleObjectData *dataPtr = GET_OLEREP(objPtr); + if (objPtr->refCount == 0 && dataPtr && dataPtr->magic == OLEDATAMAGIC) { + --dataPtr->refcount; + if (dataPtr->refcount == 0) { + Tcl_DeleteCommandFromToken(dataPtr->interp, dataPtr->command); + SET_OLEREP(objPtr, NULL); + } + } + tclCmdNameType.freeIntRepProc(objPtr); +} + +static void +CmdDupProc(Tcl_Obj *objPtr, Tcl_Obj *dupPtr) +{ + tclCmdNameType.dupIntRepProc(objPtr, dupPtr); +} + +static int +CmdSetProc(Tcl_Interp *interp, Tcl_Obj *objPtr) +{ + /* might need to do the ptr2 pointer setting etc here*/ + return tclCmdNameType.setFromAnyProc(interp, objPtr); +} + +/* + * OleObjectDelete -- + * This function is registered as the command cleanup for all + * ole commands. Its called when the command is explicitly deleted + * or when the number of objects referring to this command + * drops to 0 (see CmdFreeProc). + */ + +static void +OleObjectDelete(ClientData clientData) +{ + OleObjectData *dataPtr = clientData; + OlePackageData *pkgPtr; + Tcl_HashEntry *entryPtr; + + pkgPtr = Tcl_GetAssocData(dataPtr->interp, "ole::package", NULL); + entryPtr = Tcl_FindHashEntry(&pkgPtr->table, + (const char *)dataPtr->dispatchPtr); + if (entryPtr) { + Tcl_DeleteHashEntry(entryPtr); + } + if (dataPtr->typeinfoPtr) { + dataPtr->typeinfoPtr->lpVtbl->Release(dataPtr->typeinfoPtr); + dataPtr->typeinfoPtr = NULL; + } + if (dataPtr->dispatchPtr) { + dataPtr->dispatchPtr->lpVtbl->Release(dataPtr->dispatchPtr); + dataPtr->dispatchPtr = NULL; + } + ckfree(clientData); +} + +/* + * Ole_NewOleObj -- + * If this object is already present in our hash then reuse the + * ole package reference and create a new cmdName object for it. + * Otherwize we create a Tcl command and an OleObjectData structure + * and enter this in the hash table under its IUnknown. + */ + +Tcl_Obj * +Ole_NewOleObj(Tcl_Interp *interp, IDispatch *dispPtr) +{ + OlePackageData *pkgPtr; + OleObjectData *dataPtr; + Tcl_Obj *objPtr; + Tcl_HashEntry *entryPtr; + int isnew = 0; + char name[4 + TCL_INTEGER_SPACE]; + + pkgPtr = Tcl_GetAssocData(interp, "ole::package", NULL); + entryPtr = Tcl_CreateHashEntry(&pkgPtr->table, + (const char *)dispPtr, &isnew); + if (isnew) { + int n; + dataPtr = (OleObjectData *)ckalloc(sizeof(OleObjectData)); + dataPtr->magic = OLEDATAMAGIC; + dataPtr->id = pkgPtr->uid++; + dataPtr->dispatchPtr = dispPtr; + dataPtr->typeinfoPtr = NULL; + dataPtr->refcount = 1; + dataPtr->dispatchPtr->lpVtbl->AddRef(dataPtr->dispatchPtr); + dispPtr->lpVtbl->GetTypeInfoCount(dispPtr, &n); + if (n != 0) { + dispPtr->lpVtbl->GetTypeInfo(dispPtr, 0, LOCALE_SYSTEM_DEFAULT, + &dataPtr->typeinfoPtr); + } + + sprintf(name, "ole%lu", dataPtr->id); + dataPtr->interp = interp; + dataPtr->command = Tcl_CreateObjCommand(interp, name, + OleObjectInvoke, dataPtr, OleObjectDelete); + Tcl_SetHashValue(entryPtr, dataPtr); + } else { + dataPtr = (OleObjectData *)Tcl_GetHashValue(entryPtr); + ++dataPtr->refcount; + sprintf(name, "ole%lu", dataPtr->id); + } + + objPtr = Tcl_NewStringObj(name, -1); + Tcl_ConvertToType(interp, objPtr, Tcl_GetObjType("cmdName")); + SET_OLEREP(objPtr, dataPtr); + + return objPtr; +} + +/* + * Rewrite the Tcl cmdName type implementation to pass through + * here so we can manage object references as the command objects + * get deleted. (Ripped from tcom. Requires 8.4) + */ + +int +OleObjInit(Tcl_Interp *interp) +{ + tclCmdNameTypePtr = Tcl_GetObjType("cmdName"); + memcpy(&tclCmdNameType, tclCmdNameTypePtr, sizeof(Tcl_ObjType)); + tclCmdNameTypePtr->freeIntRepProc = CmdFreeProc; + tclCmdNameTypePtr->dupIntRepProc = CmdDupProc; + if (tclCmdNameTypePtr->updateStringProc) Tcl_Panic("oops", "oop"); + tclCmdNameTypePtr->setFromAnyProc = CmdSetProc; + return TCL_OK; +} + +/* + * Local variables: + * indent-tabs-mode: t + * tab-width: 8 + * End: + */ diff --git a/src/tclole.c b/src/tclole.c index 7acd882..6b94599 100644 --- a/src/tclole.c +++ b/src/tclole.c @@ -18,283 +18,178 @@ #pragma comment(lib, "user32") #endif -typedef enum OleTclType { - tclBooleanType, tclIntegerType, tclDoubleType, - tclListType, tclByteArrayType -} OleTclType; - -typedef struct OlePackageData -{ - size_t uid; - Tcl_HashTable table; - Tcl_ObjType *type[5]; -} OlePackageData; - -typedef struct OleObjectData -{ - unsigned long id; - long refcount; - IDispatch *dispatchPtr; - ITypeInfo *typeinfoPtr; - Tcl_Interp *interp; - Tcl_Command command; -} OleObjectData; +Tcl_ObjType *tclTypes[5]; +/* + * RefCreateObjectCmd -- + * Create COM instances. + */ -static HRESULT -OleVariantObj(Tcl_Interp *interp, VARIANT v, Tcl_Obj **resultPtrPtr) +static int +RefCreateObjectCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) { HRESULT hr = S_OK; - - /* - * FIX ME: Needs to handle VT_ARRAY and VT_BYREF flags - */ - - switch (v.vt) { - case VT_BOOL: - *resultPtrPtr = Tcl_NewBooleanObj((v.boolVal != VARIANT_FALSE)); - break; - case VT_I2: - *resultPtrPtr = Tcl_NewIntObj(v.iVal); - break; - case VT_I4: - *resultPtrPtr = Tcl_NewLongObj(v.lVal); - break; - case VT_R4: - *resultPtrPtr = Tcl_NewDoubleObj(v.fltVal); - break; - case VT_R8: - *resultPtrPtr = Tcl_NewDoubleObj(v.dblVal); - break; - case VT_UNKNOWN: - hr = VariantChangeType(&v, &v, 0, VT_DISPATCH); - if (SUCCEEDED(hr)) - *resultPtrPtr = Ole_NewComObj(interp, v.pdispVal); - break; - case VT_DISPATCH: - *resultPtrPtr = Ole_NewComObj(interp, v.pdispVal); - break; - case VT_CY: case VT_DATE: case VT_DECIMAL: - default: { - hr = VariantChangeType(&v, &v, VARIANT_ALPHABOOL, VT_BSTR); - if (SUCCEEDED(hr)) - *resultPtrPtr = Tcl_NewUnicodeObj(v.bstrVal, -1); - } - } - return hr; -} - -static DISPPARAMS * -OleDispParamsCreate(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) -{ - OlePackageData *pkgPtr; - DISPPARAMS * dp; - int cn; + CLSID clsid = CLSID_NULL; + IDispatch *dispPtr = NULL; - pkgPtr = Tcl_GetAssocData(interp, "ole::package", NULL); + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "progid"); + return TCL_ERROR; + } - dp = (DISPPARAMS*)ckalloc(sizeof(DISPPARAMS)); - if (dp != NULL) { - dp->cArgs = objc; - dp->cNamedArgs = 0; - dp->rgdispidNamedArgs = NULL; - dp->rgvarg = NULL; - if (objc > 0) { - dp->rgvarg = (VARIANT*)ckalloc(sizeof(VARIANT) * dp->cArgs); + hr = CLSIDFromProgID(Tcl_GetUnicode(objv[2]), &clsid); + if (SUCCEEDED(hr)) { + hr = CoCreateInstance(&clsid, NULL, CLSCTX_SERVER, + &IID_IDispatch, (void **)&dispPtr); + if (SUCCEEDED(hr)) { + Tcl_SetObjResult(interp, Ole_NewOleObj(interp, dispPtr)); + dispPtr->lpVtbl->Release(dispPtr); } - - /* Note: this array is filled backwards */ - for (cn = 0; cn < objc; cn++) { - Tcl_Obj *objPtr = objv[objc - cn - 1]; - Tcl_ObjType *typePtr = NULL; - VARIANT *argPtr = &dp->rgvarg[cn]; - - VariantInit(argPtr); - if (objPtr->typePtr != NULL) { - if (objPtr->typePtr == pkgPtr->type[tclBooleanType]) { - int b; - Tcl_GetBooleanFromObj(NULL, objPtr, &b); - argPtr->boolVal = (b ? VARIANT_TRUE : VARIANT_FALSE); - argPtr->vt = VT_BOOL; - } else if (objPtr->typePtr == pkgPtr->type[tclIntegerType]) { - Tcl_GetLongFromObj(NULL, objPtr, &argPtr->lVal); - argPtr->vt = VT_I4; - } else if (objPtr->typePtr == pkgPtr->type[tclDoubleType]) { - Tcl_GetDoubleFromObj(NULL, objPtr, &argPtr->dblVal); - argPtr->vt = VT_R8; - } - } - if (argPtr->vt == VT_EMPTY) { - LPCOLESTR olestr = Tcl_GetUnicode(objPtr); - argPtr->bstrVal = SysAllocString(olestr); - argPtr->vt = VT_BSTR; - } - } } - return dp; -} - -static void -OleDispParamsFree(DISPPARAMS *dp) -{ - VARIANT *pv = dp->rgvarg; - size_t n; - for (n = 0; n < dp->cArgs; n++, pv++) { - VariantClear(pv); + if (FAILED(hr)) { + Tcl_SetObjResult(interp, + Ole_Win32ErrorObj(interp, Tcl_GetString(objv[1]), hr)); + return TCL_ERROR; } - ckfree((void *)dp->rgvarg); - ckfree((void *)dp); + return TCL_OK; } + +/* + * RefGetActiveObjectCmd -- + * Get a reference to a running OLE object registered with the system. + * Registration puts objects in the Running Object Table. + */ static int -OleObjectInvoke(ClientData clientData, Tcl_Interp *interp, +RefGetActiveObjectCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { - OleObjectData *dataPtr = clientData; - HRESULT hr; - DISPID dispid; - LPWSTR name; - WORD mode = DISPATCH_PROPERTYGET | DISPATCH_METHOD; + HRESULT hr = S_OK; + CLSID clsid = CLSID_NULL; + IUnknown *unkPtr = NULL; + IDispatch *dispPtr = NULL; - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "name ?arg ...?"); + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "progid"); return TCL_ERROR; } - - name = Tcl_GetUnicode(objv[1]); - hr = dataPtr->dispatchPtr->lpVtbl->GetIDsOfNames(dataPtr->dispatchPtr, - &IID_NULL, &name, 1, LOCALE_SYSTEM_DEFAULT, &dispid); - if (SUCCEEDED(hr)) - { - VARIANT v; - EXCEPINFO ei; - DISPPARAMS *dp = NULL; - UINT uierr; - - VariantInit(&v); - dp = OleDispParamsCreate(interp, objc-2, objv+2); - - if ((mode & DISPATCH_PROPERTYPUT) || (mode & DISPATCH_PROPERTYPUTREF)) { - static DISPID putid = DISPID_PROPERTYPUT; - dp->rgdispidNamedArgs = &putid; - dp->cNamedArgs = 1; - } - - hr = dataPtr->dispatchPtr->lpVtbl->Invoke(dataPtr->dispatchPtr, - dispid, &IID_NULL, LOCALE_SYSTEM_DEFAULT, mode, dp, &v, &ei, - &uierr); - OleDispParamsFree(dp); + + hr = CLSIDFromProgID(Tcl_GetUnicode(objv[2]), &clsid); + if (SUCCEEDED(hr)) { + hr = GetActiveObject(&clsid, NULL, &unkPtr); if (SUCCEEDED(hr)) { - Tcl_Obj *resultObj = NULL; - hr = OleVariantObj(interp, v, &resultObj); + hr = unkPtr->lpVtbl->QueryInterface(unkPtr, + &IID_IDispatch, (void **)&dispPtr); if (SUCCEEDED(hr)) { - Tcl_SetObjResult(interp, resultObj); + Tcl_SetObjResult(interp, Ole_NewOleObj(interp, dispPtr)); + dispPtr->lpVtbl->Release(dispPtr); } + unkPtr->lpVtbl->Release(unkPtr); } - VariantClear(&v); } if (FAILED(hr)) { - Tcl_SetObjResult(interp, Ole_Win32ErrorObj(interp, "invoke", hr)); + Tcl_SetObjResult(interp, + Ole_Win32ErrorObj(interp, Tcl_GetString(objv[1]), hr)); return TCL_ERROR; } return TCL_OK; } + +/* + * RefGetObjectCmd -- + * Bind a COM moniker to an object instance. + */ -static void -OleObjectDelete(ClientData clientData) -{ - OleObjectData *dataPtr = clientData; - OlePackageData *pkgPtr; - Tcl_HashEntry *entryPtr; - - pkgPtr = Tcl_GetAssocData(dataPtr->interp, "ole::package", NULL); - Tcl_DeleteCommandFromToken(dataPtr->interp, dataPtr->command); - entryPtr = Tcl_FindHashEntry(&pkgPtr->table, - (const char *)dataPtr->dispatchPtr); - if (entryPtr) { - Tcl_DeleteHashEntry(entryPtr); - } - if (dataPtr->typeinfoPtr) - dataPtr->typeinfoPtr->lpVtbl->Release(dataPtr->typeinfoPtr); - dataPtr->dispatchPtr->lpVtbl->Release(dataPtr->dispatchPtr); - ckfree(clientData); -} - -Tcl_Obj * -Ole_NewComObj(Tcl_Interp *interp, IDispatch *dispPtr) +static int +RefGetObjectCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) { - OlePackageData *pkgPtr; - OleObjectData *dataPtr; - Tcl_Obj *objPtr; - Tcl_HashEntry *entryPtr; - int isnew = 0; - char name[4 + TCL_INTEGER_SPACE]; + IDispatch *dispPtr = NULL; + HRESULT hr = S_OK; - pkgPtr = Tcl_GetAssocData(interp, "ole::package", NULL); - entryPtr = Tcl_CreateHashEntry(&pkgPtr->table, - (const char *)dispPtr, &isnew); - if (isnew) { - int n; - dataPtr = (OleObjectData *)ckalloc(sizeof(OleObjectData)); - dataPtr->id = pkgPtr->uid++; - dataPtr->dispatchPtr = dispPtr; - dataPtr->typeinfoPtr = NULL; - dataPtr->refcount = 1; - dataPtr->dispatchPtr->lpVtbl->AddRef(dataPtr->dispatchPtr); - dispPtr->lpVtbl->GetTypeInfoCount(dispPtr, &n); - if (n != 0) { - dispPtr->lpVtbl->GetTypeInfo(dispPtr, 0, LOCALE_SYSTEM_DEFAULT, - &dataPtr->typeinfoPtr); - } + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "moniker"); + return TCL_ERROR; + } - sprintf(name, "ole%lu", dataPtr->id); - dataPtr->interp = interp; - dataPtr->command = Tcl_CreateObjCommand(interp, name, - OleObjectInvoke, - dataPtr, OleObjectDelete); - Tcl_SetHashValue(entryPtr, dataPtr); + hr = CoGetObject(Tcl_GetUnicode(objv[2]), + NULL, &IID_IDispatch, (void **)&dispPtr); + if (SUCCEEDED(hr)) { + Tcl_SetObjResult(interp, Ole_NewOleObj(interp, dispPtr)); + dispPtr->lpVtbl->Release(dispPtr); } else { - dataPtr = (OleObjectData *)Tcl_GetHashValue(entryPtr); - /* dataPtr->refcount ++ ?? */ - sprintf(name, "ole%lu", dataPtr->id); + Tcl_SetObjResult(interp, + Ole_Win32ErrorObj(interp, Tcl_GetString(objv[1]), hr)); + return TCL_ERROR; } - objPtr = Tcl_NewStringObj(name, -1); - //objPtr->internalRep.pr = entryPtr; - //objPtr->typePtr = &oleObjType; + return TCL_OK; +} + +/* + * RefEqualCmd -- + * Given two COM object references, return true if they refer to the + * same object instance. + */ - return objPtr; +static int +RefEqualCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +{ + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "first second"); + return TCL_ERROR; + } + /* must check the IUnknown interfaces */ + Tcl_SetResult(interp, "command not implemented", TCL_STATIC); + return TCL_ERROR; } + +/* + * RefCmd -- + * ref command ensemble + */ +struct Ensemble RefEnsemble[] = { + { "createobject", RefCreateObjectCmd, NULL }, + { "getactiveobject", RefGetActiveObjectCmd, NULL }, + { "getobject", RefGetObjectCmd, NULL }, + { "equal", RefEqualCmd, NULL }, + /* undocumented */ + /*{ "count", RefCountCmd, NULL },*/ + /*{ "querydispatch", RefQueryDispatch, NULL },*/ + /*{ "queryinterface", RefQueryInterface, NULL },*/ + NULL +}; static int -Ole_Create(ClientData clientData, Tcl_Interp *interp, +RefCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { - HRESULT hr = S_OK; - CLSID clsid = CLSID_NULL; - IDispatch *dispPtr = NULL; + struct Ensemble *ensemble = RefEnsemble; + int option = 1, index; + + while (option < objc) { + if (Tcl_GetIndexFromObjStruct(interp, objv[option], + ensemble, sizeof(ensemble[0]), "command", 0, &index) != TCL_OK) + { + return TCL_ERROR; + } - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "progid"); - return TCL_ERROR; - } - - hr = CLSIDFromProgID(Tcl_GetUnicode(objv[1]), &clsid); - if (SUCCEEDED(hr)) { - hr = CoCreateInstance(&clsid, NULL, CLSCTX_SERVER, - &IID_IDispatch, (void **)&dispPtr); - if (SUCCEEDED(hr)) { - Tcl_SetObjResult(interp, Ole_NewComObj(interp, dispPtr)); - dispPtr->lpVtbl->Release(dispPtr); - } - } - if (FAILED(hr)) { - Tcl_SetObjResult(interp, Ole_Win32ErrorObj(interp, "CreateObject", hr)); - return TCL_ERROR; + if (ensemble[index].command) { + return ensemble[index].command(clientData, interp, objc, objv); + } + ensemble = ensemble[index].ensemble; + ++option; } - return TCL_OK; + Tcl_WrongNumArgs(interp, option, objv, "command ?arg arg...?"); + return TCL_ERROR; } - + +/* + * OlePackageDataDelete -- + * Clean up the package data on interpreter shutdown. + */ static void OlePackageDataDelete(ClientData clientData, Tcl_Interp *interp) @@ -303,9 +198,10 @@ OlePackageDataDelete(ClientData clientData, Tcl_Interp *interp) Tcl_DeleteHashTable(&pkgPtr->table); ckfree(clientData); } - + /* - * Package initialization + * Ole_Init -- + * Package initialization for each interpreter. */ #define TCL_VERSION_WRONG "8.0" /* see tktable bug #1091431 */ @@ -330,16 +226,19 @@ Ole_Init(Tcl_Interp *interp) pkgPtr = (OlePackageData *)ckalloc(sizeof(OlePackageData)); pkgPtr->uid = 0; - pkgPtr->type[tclBooleanType] = Tcl_GetObjType("boolean"); - pkgPtr->type[tclIntegerType] = Tcl_GetObjType("int"); - pkgPtr->type[tclDoubleType] = Tcl_GetObjType("double"); - pkgPtr->type[tclByteArrayType] = Tcl_GetObjType("bytearray"); - pkgPtr->type[tclListType] = Tcl_GetObjType("list"); Tcl_InitHashTable(&pkgPtr->table, TCL_ONE_WORD_KEYS); Tcl_SetAssocData(interp, "ole::package", OlePackageDataDelete, pkgPtr); - + + tclTypes[tclBooleanType] = Tcl_GetObjType("boolean"); + tclTypes[tclIntegerType] = Tcl_GetObjType("int"); + tclTypes[tclDoubleType] = Tcl_GetObjType("double"); + tclTypes[tclByteArrayType] = Tcl_GetObjType("bytearray"); + tclTypes[tclListType] = Tcl_GetObjType("list"); + + OleObjInit(interp); + /* create commands */ - Tcl_CreateObjCommand(interp, "ole::create", Ole_Create, NULL, NULL); + Tcl_CreateObjCommand(interp, "ole::ref", RefCmd, NULL, NULL); Tcl_PkgProvideEx(interp, PACKAGE_NAME, PACKAGE_VERSION, NULL); return TCL_OK; diff --git a/src/tcloleInt.h b/src/tcloleInt.h index 13a2906..5b7ff23 100644 --- a/src/tcloleInt.h +++ b/src/tcloleInt.h @@ -15,6 +15,7 @@ #define WIN32_LEAN_AND_MEAN #include #include +#include #include "tclole.h" @@ -30,14 +31,71 @@ extern "C" { #endif -Tcl_Obj * Ole_NewComObj(Tcl_Interp *interp, IDispatch *dispPtr); +typedef enum OleTclType { + tclBooleanType, tclIntegerType, tclDoubleType, + tclListType, tclByteArrayType +} OleTclType; +typedef struct OlePackageData +{ + size_t uid; + Tcl_HashTable table; +} OlePackageData; -/* util.c */ +#define OLEDATAMAGIC 0x01656C6FUL + +typedef struct OleObjectData +{ + unsigned long magic; + unsigned long id; + long refcount; + IDispatch *dispatchPtr; + ITypeInfo *typeinfoPtr; + Tcl_Interp *interp; + Tcl_Command command; +} OleObjectData; + +struct Ensemble { + const char *name; /* subcommand name */ + Tcl_ObjCmdProc *command; /* subcommand implementation OR */ + struct Ensemble *ensemble; /* subcommand ensemble */ +}; + +extern Tcl_ObjType *tclTypes[5]; + +#define GET_VARIANTREP(objPtr) \ + ((VARIANT *) (objPtr)->internalRep.otherValuePtr) +#define SET_VARIANTREP(objPtr, vPtr) \ + (objPtr)->internalRep.otherValuePtr = (VOID *) (vPtr) + +extern Tcl_ObjType tclVariantType; +#if 1 //ndef _DEBUG +#define OLE_ASSERT(x) ((void)0) +#define OLE_TRACE 1 ? ((void)0) : LocalTrace +#else /* _DEBUG */ +#define OLE_ASSERT(x) if (!(x)) _assert(#x, __FILE__, __LINE__) +#define OLE_TRACE LocalTrace +#endif /* _DEBUG */ + +/* invoke.c */ +int OleObjectInvoke(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); + +/* oleobj.c */ +int OleObjInit(Tcl_Interp *interp); +Tcl_Obj * Ole_NewOleObj(Tcl_Interp *interp, IDispatch *dispPtr); + +/* util.c */ +void LocalTrace(const char *format, ...); Tcl_Obj * Ole_Win32ErrorObj(Tcl_Interp *interp, const char *prefix, DWORD errorCode); int Ole_SetObjResult(Tcl_Interp *interp, const char *prefix, DWORD errorCode); +/* varobj.c */ + +Tcl_Obj * Ole_NewVariantObj(const VARIANT v); +void Ole_SetVariantObj(Tcl_Obj *objPtr, const VARIANT v); + #ifdef __cplusplus } diff --git a/src/util.c b/src/util.c index 927f5e5..e060e65 100644 --- a/src/util.c +++ b/src/util.c @@ -9,6 +9,20 @@ */ #include "tcloleInt.h" +#include + +void +LocalTrace(const char *format, ...) +{ + const int max = 511; + char buffer[512]; + va_list args; + va_start (args, format); + _vsnprintf(buffer, max, format, args); + va_end(args); + buffer[max] = 0; + OutputDebugStringA(buffer); +} Tcl_Obj * Ole_Win32ErrorObj(Tcl_Interp *interp, const char *prefix, DWORD errorCode) diff --git a/src/varobj.c b/src/varobj.c new file mode 100644 index 0000000..583b5da --- /dev/null +++ b/src/varobj.c @@ -0,0 +1,147 @@ +/* varobj.c - Copyright (C) 2007 Pat Thoyts + * + * Minimal COM Automation package + * + * See the file "LICENSE" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * $Id$ + */ + +#include "tcloleInt.h" + +static void FreeVariant(Tcl_Obj *objPtr); +static void DupVariant(Tcl_Obj *objPtr, Tcl_Obj *dupPtr); +static void UpdateString(Tcl_Obj *objPtr); +static int SetVariantFromAny(Tcl_Interp *, Tcl_Obj *objPtr); + +Tcl_ObjType tclVariantType = { + "tclole::variant", + FreeVariant, /* freeIntRepProc */ + DupVariant, /* dupIntRepProc */ + UpdateString, /* updateStringProc */ + SetVariantFromAny, /* setFromAnyProc */ +}; + +static void +FreeVariant(Tcl_Obj *objPtr) +{ + VariantClear(GET_VARIANTREP(objPtr)); + ckfree((char *)GET_VARIANTREP(objPtr)); + OLE_TRACE("free variant %p\n", GET_VARIANTREP(objPtr)); +} + +static void +DupVariant(Tcl_Obj *objPtr, Tcl_Obj *dupPtr) +{ + VARIANT *varPtr = (VARIANT *)ckalloc(sizeof(VARIANT)); + VariantInit(varPtr); + VariantCopy(varPtr, GET_VARIANTREP(objPtr)); + SET_VARIANTREP(dupPtr, varPtr); + dupPtr->typePtr = &tclVariantType; + OLE_TRACE("duplicate variant %p to %p\n", GET_VARIANTREP(objPtr), varPtr); +} + +static void +UpdateString(Tcl_Obj *objPtr) +{ + VARIANT v; + HRESULT hr; + VariantInit(&v); + hr = VariantChangeType(&v, GET_VARIANTREP(objPtr), + VARIANT_ALPHABOOL, VT_BSTR); + if (SUCCEEDED(hr)) { + objPtr->length = WideCharToMultiByte(CP_UTF8, 0, + v.bstrVal, -1, NULL, 0, NULL, NULL); + objPtr->bytes = ckalloc(objPtr->length); + objPtr->length = WideCharToMultiByte(CP_UTF8, 0, + v.bstrVal, -1, objPtr->bytes, objPtr->length, NULL, NULL); + VariantClear(&v); + } else { + objPtr->length = 0; + objPtr->bytes = ckalloc(1); + objPtr->bytes[0] = 0; + } + OLE_TRACE("update string from variant %p: '%s'\n", + GET_VARIANTREP(objPtr), objPtr->bytes); +} + +static int +SetVariantFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr) +{ + if (objPtr->typePtr != &tclVariantType) + { + VARIANT *varPtr = (VARIANT *)ckalloc(sizeof(VARIANT)); + VariantInit(varPtr); + if (objPtr->typePtr == tclTypes[tclBooleanType]) { + int b; + Tcl_GetBooleanFromObj(NULL, objPtr, &b); + varPtr->boolVal = (b ? VARIANT_TRUE : VARIANT_FALSE); + varPtr->vt = VT_BOOL; + } else if (objPtr->typePtr == tclTypes[tclIntegerType]) { + Tcl_GetIntFromObj(NULL, objPtr, &varPtr->intVal); + varPtr->vt = VT_INT; + } else if (objPtr->typePtr == tclTypes[tclDoubleType]) { + Tcl_GetDoubleFromObj(NULL, objPtr, &varPtr->dblVal); + varPtr->vt = VT_R8; + } else { + /* get string, convert to BSTR */ + LPOLESTR olestr; + int cch, cwch; + const char *s = Tcl_GetStringFromObj(objPtr, &cch); + cwch = MultiByteToWideChar(CP_UTF8, 0, s, cch, NULL, 0); + olestr = (LPOLESTR)ckalloc(sizeof(OLECHAR) * cwch); + MultiByteToWideChar(CP_UTF8, 0, s, cch, olestr, cwch); + varPtr->bstrVal = SysAllocString(olestr); + varPtr->vt = VT_BSTR; + ckfree((char *)olestr); + } + + Tcl_InvalidateStringRep(objPtr); + if (objPtr->typePtr->freeIntRepProc != NULL) { + objPtr->typePtr->freeIntRepProc(objPtr); + } + SET_VARIANTREP(objPtr, varPtr); + objPtr->typePtr = &tclVariantType; + OLE_TRACE("set variant created %p\n", varPtr); + } else { + OLE_TRACE("set variant called on variant obj %p\n", + GET_VARIANTREP(objPtr)); + } + + return TCL_OK; +} + +Tcl_Obj * +Ole_NewVariantObj(const VARIANT v) +{ + Tcl_Obj *objPtr = Tcl_NewObj(); + Ole_SetVariantObj(objPtr, v); + return objPtr; +} + +void +Ole_SetVariantObj(Tcl_Obj *objPtr, const VARIANT v) +{ + VARIANT *varPtr; + + if (Tcl_IsShared(objPtr)) { + Tcl_Panic("%s called with shared object", "Ole_SetVariantObj"); + } + Tcl_InvalidateStringRep(objPtr); + if (objPtr->typePtr && objPtr->typePtr->freeIntRepProc != NULL) { + objPtr->typePtr->freeIntRepProc(objPtr); + } + varPtr = (VARIANT *)ckalloc(sizeof(VARIANT)); + VariantInit(varPtr); + VariantCopy(varPtr, GET_VARIANTREP(objPtr)); + SET_VARIANTREP(objPtr, varPtr); + objPtr->typePtr = &tclVariantType; +} + +/* + * Local variables: + * indent-tabs-mode: t + * tab-width: 8 + * End: + */ diff --git a/win/makefile.vc b/win/makefile.vc index d1ab215..8d76ec9 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -164,12 +164,15 @@ PROJECT = tclole #PROJECT_REQUIRES_TK=1 !include "rules.vc" -DOTVERSION = 0.1 +DOTVERSION = 0.2 VERSION = $(DOTVERSION:.=) STUBPREFIX = $(PROJECT)stub DLLOBJS = \ $(TMP_DIR)\tclole.obj \ + $(TMP_DIR)\invoke.obj \ + $(TMP_DIR)\oleobj.obj \ + $(TMP_DIR)\varobj.obj \ $(TMP_DIR)\util.obj \ !if !$(STATIC_BUILD) $(TMP_DIR)\tclole.res @@ -347,7 +350,7 @@ source all.tcl shell: setup $(PROJECT) @set TCL_LIBRARY=$(TCL_LIBRARY:\=/) @set TCLLIBPATH=$(OUT_DIR:\=/) $(LIBDIR:\=/) - $(TCLSH) + $(DEBUGGER) $(TCLSH) setup: @if not exist $(OUT_DIR)\nul mkdir $(OUT_DIR) -- 2.23.0