#! /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
# 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.
# 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]...
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
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.
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 $@
#-----------------------------------------------------------------------
- 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
\$*)
} >&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
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'`\\"
# 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.
# 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([])
--- /dev/null
+/* invoke.c - Copyright (C) 2007 Pat Thoyts <patthoyts@users.sourceforge.net>
+ *
+ * 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:
+ */
--- /dev/null
+/* oleobj.c - Copyright (C) 2007 Pat Thoyts <patthoyts@users.sourceforge.net>
+ *
+ * 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);
+}
+\f
+/*
+ * 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);
+}
+\f
+/*
+ * 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;
+}
+\f
+/*
+ * 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:
+ */
#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;
}
+\f
+/*
+ * 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;
}
+\f
+/*
+ * 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;
+}
+\f
+/*
+ * 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;
}
+\f
+/*
+ * 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;
}
-
+\f
+/*
+ * OlePackageDataDelete --
+ * Clean up the package data on interpreter shutdown.
+ */
static void
OlePackageDataDelete(ClientData clientData, Tcl_Interp *interp)
Tcl_DeleteHashTable(&pkgPtr->table);
ckfree(clientData);
}
-
+\f
/*
- * Package initialization
+ * Ole_Init --
+ * Package initialization for each interpreter.
*/
#define TCL_VERSION_WRONG "8.0" /* see tktable bug #1091431 */
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;
#define WIN32_LEAN_AND_MEAN
#include <windows.h>
#include <ole2.h>
+#include <assert.h>
#include "tclole.h"
#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
}
*/
#include "tcloleInt.h"
+#include <ctype.h>
+
+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)
--- /dev/null
+/* varobj.c - Copyright (C) 2007 Pat Thoyts <patthoyts@users.sourceforge.net>
+ *
+ * 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:
+ */
#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
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)
projects / tclole / commitdiff