From: Pat Thoyts Date: Wed, 5 Dec 2007 00:51:18 +0000 (+0000) Subject: Added tests. Implemented single variable version of ole::foreach X-Git-Tag: tclole-0-3~2 X-Git-Url: https://privyetmir.co.uk/gitweb.cgi?a=commitdiff_plain;h=e95cdcefd7f9355271f13bb68bedc0cc620c0879;p=tclole Added tests. Implemented single variable version of ole::foreach --- diff --git a/configure b/configure index c0b7542..a946a63 100755 --- a/configure +++ b/configure @@ -6133,7 +6133,7 @@ done #----------------------------------------------------------------------- - 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 \$*) diff --git a/configure.in b/configure.in index a6c8655..c55b4dc 100644 --- a/configure.in +++ b/configure.in @@ -71,7 +71,7 @@ TEA_SETUP_COMPILER # 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([]) diff --git a/src/foreach.c b/src/foreach.c new file mode 100644 index 0000000..8e13fc4 --- /dev/null +++ b/src/foreach.c @@ -0,0 +1,102 @@ +/* foreach.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 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: + */ diff --git a/src/invoke.c b/src/invoke.c index edd6869..89099e3 100644 --- a/src/invoke.c +++ b/src/invoke.c @@ -10,7 +10,7 @@ #include "tcloleInt.h" -static HRESULT +HRESULT OleVariantObj(Tcl_Interp *interp, VARIANT v, Tcl_Obj **resultPtrPtr) { HRESULT hr = S_OK; @@ -83,20 +83,27 @@ OleDispParamsCreate(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) 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) { diff --git a/src/oleobj.c b/src/oleobj.c index 764b2f0..e76ad1a 100644 --- a/src/oleobj.c +++ b/src/oleobj.c @@ -25,11 +25,6 @@ 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; @@ -89,6 +84,10 @@ OleObjectDelete(ClientData clientData) 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; @@ -123,9 +122,12 @@ Ole_NewOleObj(Tcl_Interp *interp, IDispatch *dispPtr) 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, diff --git a/src/tclole.c b/src/tclole.c index 6b94599..92bfc18 100644 --- a/src/tclole.c +++ b/src/tclole.c @@ -18,7 +18,7 @@ #pragma comment(lib, "user32") #endif -Tcl_ObjType *tclTypes[5]; +Tcl_ObjType *tclTypes[6]; /* * RefCreateObjectCmd -- @@ -136,13 +136,29 @@ static int 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; } /* @@ -159,7 +175,7 @@ struct Ensemble RefEnsemble[] = { /*{ "count", RefCountCmd, NULL },*/ /*{ "querydispatch", RefQueryDispatch, NULL },*/ /*{ "queryinterface", RefQueryInterface, NULL },*/ - NULL + { NULL } }; static int @@ -229,16 +245,18 @@ Ole_Init(Tcl_Interp *interp) 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; diff --git a/src/tcloleInt.h b/src/tcloleInt.h index 5b7ff23..6eff8ef 100644 --- a/src/tcloleInt.h +++ b/src/tcloleInt.h @@ -32,10 +32,12 @@ extern "C" { 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; @@ -49,6 +51,7 @@ typedef struct OleObjectData unsigned long magic; unsigned long id; long refcount; + IUnknown *unknownPtr; IDispatch *dispatchPtr; ITypeInfo *typeinfoPtr; Tcl_Interp *interp; @@ -61,15 +64,17 @@ struct Ensemble { 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 @@ -78,9 +83,14 @@ extern Tcl_ObjType tclVariantType; #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); diff --git a/src/varobj.c b/src/varobj.c index 583b5da..82dba41 100644 --- a/src/varobj.c +++ b/src/varobj.c @@ -73,15 +73,15 @@ SetVariantFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr) { 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 { diff --git a/tests/all.tcl b/tests/all.tcl new file mode 100644 index 0000000..e300c57 --- /dev/null +++ b/tests/all.tcl @@ -0,0 +1,5 @@ +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 diff --git a/tests/core.test b/tests/core.test new file mode 100644 index 0000000..63ca030 --- /dev/null +++ b/tests/core.test @@ -0,0 +1,89 @@ +# 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 diff --git a/win/makefile.vc b/win/makefile.vc index 8d76ec9..c1d5095 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -170,6 +170,7 @@ STUBPREFIX = $(PROJECT)stub DLLOBJS = \ $(TMP_DIR)\tclole.obj \ + $(TMP_DIR)\foreach.obj\ $(TMP_DIR)\invoke.obj \ $(TMP_DIR)\oleobj.obj \ $(TMP_DIR)\varobj.obj \ @@ -324,28 +325,10 @@ $(PROJECT): setup $(PRJLIB) pkgIndex 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:\=/)