#-----------------------------------------------------------------------
- vars="src/tclole.c src/invoke.c src/oleobj.c src/varobj.c src/util.c"
+ vars="src/tclole.c src/foreach.c src/invoke.c src/oleobj.c src/varobj.c src/util.c"
for i in $vars; do
case $i in
\$*)
# and PKG_TCL_SOURCES.
#-----------------------------------------------------------------------
-TEA_ADD_SOURCES([src/tclole.c src/invoke.c src/oleobj.c src/varobj.c src/util.c])
+TEA_ADD_SOURCES([src/tclole.c src/foreach.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
+/* foreach.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 int
+EvalBody(Tcl_Interp *interp, Tcl_Obj *varnameObj, VARIANT v, Tcl_Obj *bodyObj)
+{
+ int r = TCL_ERROR;
+ Tcl_Obj *varObj = NULL;
+ HRESULT hr = OleVariantObj(interp, v, &varObj);
+ if (SUCCEEDED(hr)) {
+ Tcl_Obj *setObj = Tcl_ObjSetVar2(interp, varnameObj, NULL,
+ varObj, TCL_LEAVE_ERR_MSG);
+ if (setObj != NULL) {
+ r = Tcl_EvalObjEx(interp, bodyObj, 0);
+ }
+ } else {
+ r = Ole_SetObjResult(interp, "evalbody", hr);
+ }
+ return r;
+}
+
+int
+OleForeachCmd(ClientData clientData, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[])
+{
+ HRESULT hr = S_OK;
+ OleObjectData *dataPtr = NULL;
+ VARIANT vEnum;
+ DISPPARAMS dpNull = {NULL, NULL, 0, 0};
+ int r = TCL_OK;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 1, objv, "varname collection script");
+ return TCL_ERROR;
+ }
+
+ if (objv[2]->typePtr == tclTypes[tclCmdNameIndex]) {
+ dataPtr = GET_OLEREP(objv[2]);
+ }
+ if (dataPtr == NULL || dataPtr->magic != OLEDATAMAGIC) {
+ Tcl_SetResult(interp, "wrong type", TCL_STATIC);
+ return TCL_ERROR;
+ }
+
+ VariantInit(&vEnum);
+ hr = dataPtr->dispatchPtr->lpVtbl->Invoke(dataPtr->dispatchPtr,
+ DISPID_NEWENUM, &IID_NULL, LOCALE_SYSTEM_DEFAULT, DISPATCH_PROPERTYGET,
+ &dpNull, &vEnum, NULL, NULL);
+ if (SUCCEEDED(hr)) {
+ IEnumVARIANT *enumPtr = NULL;
+ hr = vEnum.punkVal->lpVtbl->QueryInterface(vEnum.punkVal,
+ &IID_IEnumVARIANT, (void **)&enumPtr);
+ if (SUCCEEDED(hr)) {
+ HRESULT hrLoop = S_OK;
+ ULONG n, cElt;
+ VARIANT rgVar[16];
+
+ for (n = 0; n < 16; n++) {
+ VariantInit(&rgVar[n]);
+ }
+
+ while (SUCCEEDED(hr) && hrLoop == S_OK
+ && (r == TCL_OK || r == TCL_CONTINUE)) {
+ hrLoop = enumPtr->lpVtbl->Next(enumPtr, 16, rgVar, &cElt);
+ for (n = 0; SUCCEEDED(hr) && n < cElt; ++n) {
+
+ r = EvalBody(interp, objv[1], rgVar[n], objv[3]);
+ if (!(r == TCL_OK || r == TCL_CONTINUE)) {
+ break;
+ }
+
+ }
+ for (n = 0; n < cElt; ++n) {
+ VariantClear(&rgVar[n]);
+ }
+ }
+
+ enumPtr->lpVtbl->Release(enumPtr);
+ }
+ }
+ if (FAILED(hr)) {
+ r = Ole_SetObjResult(interp, "foreach", hr);
+ }
+ VariantClear(&vEnum);
+ return r;
+}
+
+/*
+ * Local variables:
+ * indent-tabs-mode: t
+ * tab-width: 8
+ * End:
+ */
#include "tcloleInt.h"
-static HRESULT
+HRESULT
OleVariantObj(Tcl_Interp *interp, VARIANT v, Tcl_Obj **resultPtrPtr)
{
HRESULT hr = S_OK;
VariantInit(argPtr);
if (objPtr->typePtr != NULL) {
- if (objPtr->typePtr == tclTypes[tclBooleanType]) {
+ if (objPtr->typePtr == tclTypes[tclBooleanIndex]) {
int b;
Tcl_GetBooleanFromObj(NULL, objPtr, &b);
argPtr->boolVal = (b ? VARIANT_TRUE : VARIANT_FALSE);
argPtr->vt = VT_BOOL;
- } else if (objPtr->typePtr == tclTypes[tclIntegerType]) {
+ } else if (objPtr->typePtr == tclTypes[tclIntegerIndex]) {
Tcl_GetLongFromObj(NULL, objPtr, &argPtr->lVal);
argPtr->vt = VT_I4;
- } else if (objPtr->typePtr == tclTypes[tclDoubleType]) {
+ } else if (objPtr->typePtr == tclTypes[tclDoubleIndex]) {
Tcl_GetDoubleFromObj(NULL, objPtr, &argPtr->dblVal);
argPtr->vt = VT_R8;
} else if (objPtr->typePtr == &tclVariantType) {
VariantCopy(argPtr, GET_VARIANTREP(objPtr));
argPtr->vt = VT_VARIANT;
+ } else if (objPtr->typePtr == tclTypes[tclCmdNameIndex]) {
+ OleObjectData *dataPtr = GET_OLEREP(objPtr);
+ if (dataPtr && dataPtr->magic == OLEDATAMAGIC) {
+ argPtr->pdispVal = dataPtr->dispatchPtr;
+ argPtr->pdispVal->lpVtbl->AddRef(argPtr->pdispVal);
+ argPtr->vt = VT_DISPATCH;
+ }
}
}
if (argPtr->vt == VT_EMPTY) {
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;
dataPtr->typeinfoPtr->lpVtbl->Release(dataPtr->typeinfoPtr);
dataPtr->typeinfoPtr = NULL;
}
+ if (dataPtr->unknownPtr) {
+ dataPtr->unknownPtr->lpVtbl->Release(dataPtr->unknownPtr);
+ dataPtr->unknownPtr = NULL;
+ }
if (dataPtr->dispatchPtr) {
dataPtr->dispatchPtr->lpVtbl->Release(dataPtr->dispatchPtr);
dataPtr->dispatchPtr = NULL;
dataPtr->magic = OLEDATAMAGIC;
dataPtr->id = pkgPtr->uid++;
dataPtr->dispatchPtr = dispPtr;
+ dataPtr->unknownPtr = NULL;
dataPtr->typeinfoPtr = NULL;
dataPtr->refcount = 1;
dataPtr->dispatchPtr->lpVtbl->AddRef(dataPtr->dispatchPtr);
+ dataPtr->dispatchPtr->lpVtbl->QueryInterface(dataPtr->dispatchPtr,
+ &IID_IUnknown, (void **)&dataPtr->unknownPtr);
dispPtr->lpVtbl->GetTypeInfoCount(dispPtr, &n);
if (n != 0) {
dispPtr->lpVtbl->GetTypeInfo(dispPtr, 0, LOCALE_SYSTEM_DEFAULT,
#pragma comment(lib, "user32")
#endif
-Tcl_ObjType *tclTypes[5];
+Tcl_ObjType *tclTypes[6];
/*
* RefCreateObjectCmd --
RefEqualCmd(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
{
+ int result = 0;
+
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;
+
+ /*
+ * Must be cmdName types and the IUnknowns must match
+ */
+
+ if (objv[2]->typePtr == tclTypes[tclCmdNameIndex]
+ && objv[3]->typePtr == tclTypes[tclCmdNameIndex]) {
+ OleObjectData *firstPtr = GET_OLEREP(objv[2]);
+ OleObjectData *secondPtr = GET_OLEREP(objv[3]);
+ if (firstPtr && firstPtr->magic == OLEDATAMAGIC
+ && secondPtr && secondPtr->magic == OLEDATAMAGIC) {
+ result = (firstPtr->unknownPtr == secondPtr->unknownPtr);
+ }
+ }
+
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
+ return TCL_OK;
}
\f
/*
/*{ "count", RefCountCmd, NULL },*/
/*{ "querydispatch", RefQueryDispatch, NULL },*/
/*{ "queryinterface", RefQueryInterface, NULL },*/
- NULL
+ { NULL }
};
static int
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");
+ tclTypes[tclBooleanIndex] = Tcl_GetObjType("boolean");
+ tclTypes[tclIntegerIndex] = Tcl_GetObjType("int");
+ tclTypes[tclDoubleIndex] = Tcl_GetObjType("double");
+ tclTypes[tclByteArrayIndex] = Tcl_GetObjType("bytearray");
+ tclTypes[tclListIndex] = Tcl_GetObjType("list");
+ tclTypes[tclCmdNameIndex] = Tcl_GetObjType("cmdName");
OleObjInit(interp);
/* create commands */
Tcl_CreateObjCommand(interp, "ole::ref", RefCmd, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "ole::foreach", OleForeachCmd, NULL, NULL);
Tcl_PkgProvideEx(interp, PACKAGE_NAME, PACKAGE_VERSION, NULL);
return TCL_OK;
typedef enum OleTclType {
- tclBooleanType, tclIntegerType, tclDoubleType,
- tclListType, tclByteArrayType
+ tclBooleanIndex, tclIntegerIndex, tclDoubleIndex,
+ tclListIndex, tclByteArrayIndex, tclCmdNameIndex,
} OleTclType;
+extern Tcl_ObjType *tclTypes[6];
+
typedef struct OlePackageData
{
size_t uid;
unsigned long magic;
unsigned long id;
long refcount;
+ IUnknown *unknownPtr;
IDispatch *dispatchPtr;
ITypeInfo *typeinfoPtr;
Tcl_Interp *interp;
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;
+#define GET_OLEREP(objPtr) \
+ ((OleObjectData *)(objPtr)->internalRep.twoPtrValue.ptr2)
+#define SET_OLEREP(objPtr, dataPtr) \
+ (objPtr)->internalRep.twoPtrValue.ptr2 = (void *)(dataPtr)
+
#if 1 //ndef _DEBUG
#define OLE_ASSERT(x) ((void)0)
#define OLE_TRACE 1 ? ((void)0) : LocalTrace
#define OLE_TRACE LocalTrace
#endif /* _DEBUG */
+int OleForeachCmd(ClientData clientData, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
+
/* invoke.c */
int OleObjectInvoke(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
+HRESULT OleVariantObj(Tcl_Interp *interp, VARIANT v,
+ Tcl_Obj **resultPtrPtr);
/* oleobj.c */
int OleObjInit(Tcl_Interp *interp);
{
VARIANT *varPtr = (VARIANT *)ckalloc(sizeof(VARIANT));
VariantInit(varPtr);
- if (objPtr->typePtr == tclTypes[tclBooleanType]) {
+ if (objPtr->typePtr == tclTypes[tclBooleanIndex]) {
int b;
Tcl_GetBooleanFromObj(NULL, objPtr, &b);
varPtr->boolVal = (b ? VARIANT_TRUE : VARIANT_FALSE);
varPtr->vt = VT_BOOL;
- } else if (objPtr->typePtr == tclTypes[tclIntegerType]) {
+ } else if (objPtr->typePtr == tclTypes[tclIntegerIndex]) {
Tcl_GetIntFromObj(NULL, objPtr, &varPtr->intVal);
varPtr->vt = VT_INT;
- } else if (objPtr->typePtr == tclTypes[tclDoubleType]) {
+ } else if (objPtr->typePtr == tclTypes[tclDoubleIndex]) {
Tcl_GetDoubleFromObj(NULL, objPtr, &varPtr->dblVal);
varPtr->vt = VT_R8;
} else {
--- /dev/null
+package require Tcl 8.4
+package require tcltest 2.2
+::tcltest::configure -testdir [file dirname [file normalize [info script]]]
+eval ::tcltest::configure $argv
+::tcltest::runAllTests
--- /dev/null
+# core.test -*- tcl -*-
+package require tcltest
+namespace import -force ::tcltest::test
+
+package require tclole
+
+# -------------------------------------------------------------------------
+
+test core-1.0 {} -body {
+ info commands ole::ref
+} -result {::ole::ref}
+
+test core-1.1 {} -body {
+ ole::ref
+} -returnCodes 1 -match glob -result {wrong # args: *}
+
+test core-1.2 {} -body {
+ ole::ref zzz
+} -returnCodes 1 -match glob -result {bad command "zzz": *}
+
+test core-2.0 {dictionary: create and implicit release} -body {
+ ole::ref createobject Scripting.Dictionary
+} -match regexp -result {ole\d+}
+
+test core-2.1 {dictionary: create and explicit delete} -body {
+ set d [ole::ref createobject Scripting.Dictionary]
+ unset d
+} -result {}
+
+test core-2.2 {dictionary: invoke property get} -setup {
+ set d [ole::ref createobject Scripting.Dictionary]
+} -body {
+ $d Count
+} -cleanup {
+ unset d
+} -result {0}
+
+test core-2.3 {dictionary: invoke method} -setup {
+ set d [ole::ref createobject Scripting.Dictionary]
+} -body {
+ list [$d Add key1 value1] [$d Count]
+} -cleanup {
+ unset d
+} -result {{} 1}
+
+test core-2.3 {dictionary: invoke method} -setup {
+ set d [ole::ref createobject Scripting.Dictionary]
+} -body {
+ list [$d Add key1 value1] [$d Add key2 3.14] [$d Count]
+} -cleanup {
+ unset d
+} -result {{} {} 2}
+
+test core-2.4 {dictionary: invoke method} -setup {
+ set d [ole::ref createobject Scripting.Dictionary]
+} -body {
+ $d Add key1 value1
+ $d Add key2 3.14
+ $d Remove key1
+ $d Count
+} -cleanup {
+ unset d
+} -result {1}
+
+test core-3.0 {ole::ref equal} -setup {
+ set d [ole::ref createobject Scripting.Dictionary]
+ set e [ole::ref createobject Scripting.Dictionary]
+} -body {
+ $d Add key1 $e
+ set f [$d Item key1]
+ ole::ref equal $e $f
+} -cleanup {
+ unset d e f
+} -result {1}
+
+test core-3.1 {ole::ref equal: not equal} -setup {
+ set d [ole::ref createobject Scripting.Dictionary]
+ set e [ole::ref createobject Scripting.Dictionary]
+} -body {
+ $d Add key1 $e
+ set f [$d Item key1]
+ ole::ref equal $d $f
+} -cleanup {
+ unset d e f
+} -result {0}
+
+# -------------------------------------------------------------------------
+
+tcltest::cleanupTests
DLLOBJS = \
$(TMP_DIR)\tclole.obj \
+ $(TMP_DIR)\foreach.obj\
$(TMP_DIR)\invoke.obj \
$(TMP_DIR)\oleobj.obj \
$(TMP_DIR)\varobj.obj \
install: install-binaries install-libraries install-docs
pkgIndex: setup $(OUT_DIR)\pkgIndex.tcl
-# Tests need to ensure we load the right dll file we
-# have to handle the output differently on Win9x.
-#
test: setup $(PROJECT)
@set TCL_LIBRARY=$(TCL_LIBRARY:\=/)
@set TCLLIBPATH=$(OUT_DIR:\=/) $(LIBDIR:\=/)
-!if "$(OS)" == "Windows_NT" || "$(MSVCDIR)" == "IDE"
- $(TCLSH) <<
-cd "$(ROOT)/tests"
-set argv "$(TESTFLAGS)"
-source all.tcl
-<<
-!else
- echo Please wait while the test results are collected
- $(TCLSH) << >tests.log
-load $(PRJLIB:\=/)
-cd "$(ROOT)/tests"
-set argv "$(TESTFLAGS)"
-source all.tcl
-<<
- type tests.log | more
-!endif
+ $(DEBUGGER) $(TCLSH) "$(ROOT)/tests/all.tcl" $(TESTFLAGS)
shell: setup $(PROJECT)
@set TCL_LIBRARY=$(TCL_LIBRARY:\=/)
projects / tclole / commitdiff