From bff490c5d893ee9f4af867862e1e9acd580cef1f Mon Sep 17 00:00:00 2001 From: Pat Thoyts Date: Wed, 12 Dec 2007 01:59:21 +0000 Subject: [PATCH] Added foreach and started on bind. Fixed double release of bstrs in the OleVariantObject handling. --- configure | 18 ++-- configure.in | 2 +- library/http.tcl | 161 ++++++++++++++++++++++++++++++++++ src/bgeval.c | 83 ++++++++++++++++++ src/bind.c | 79 +++++++++++++++++ src/coimpl.c | 224 +++++++++++++++++++++++++++++++++++++++++++++++ src/foreach.c | 7 +- src/invoke.c | 151 +++++++++++++++++++++++++------- src/tclole.c | 9 ++ src/tcloleInt.h | 11 ++- win/makefile.vc | 11 ++- 11 files changed, 708 insertions(+), 48 deletions(-) create mode 100644 library/http.tcl create mode 100644 src/bgeval.c create mode 100644 src/bind.c create mode 100644 src/coimpl.c diff --git a/configure b/configure index a946a63..36c8617 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.2. +# Generated by GNU Autoconf 2.59 for tclole 0.3. # # 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.2' -PACKAGE_STRING='tclole 0.2' +PACKAGE_VERSION='0.3' +PACKAGE_STRING='tclole 0.3' 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.2 to adapt to many kinds of systems. +\`configure' configures tclole 0.3 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.2:";; + short | recursive ) echo "Configuration of tclole 0.3:";; 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.2 +tclole configure 0.3 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.2, which was +It was created by tclole $as_me 0.3, which was generated by GNU Autoconf 2.59. Invocation command line was $ $0 $@ @@ -10733,7 +10733,7 @@ _ASBOX } >&5 cat >&5 <<_CSEOF -This file was extended by tclole $as_me 0.2, which was +This file was extended by tclole $as_me 0.3, 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.2 +tclole config.status 0.3 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 c55b4dc..9a0a6d7 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.2]) +AC_INIT([tclole], [0.3]) #-------------------------------------------------------------------- # Call TEA_INIT as the first TEA_ macro to set up initial vars. diff --git a/library/http.tcl b/library/http.tcl new file mode 100644 index 0000000..d98fd6d --- /dev/null +++ b/library/http.tcl @@ -0,0 +1,161 @@ +# http.tcl - 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$ +# + +package require tclole + +namespace eval ::ole::http { + variable version 1.0.0 + variable watchlist {} + variable watchtimer {} + + namespace export geturl +} + +proc ::ole::http::geturl {url args} { + variable uid + set token [namespace current]::http[incr uid] + upvar #0 $token state + array set state {method GET -query "" -command {} -timeout {} -progress {} -headers {}} + set state(url) $url + + while {[string match -* [set option [lindex $args 0]]]} { + switch -exact -- $option { + -query { set state(-query) [Pop args 1] } + -command { set state(-command) [Pop args 1] } + -timeout { set state(-timeout) [Pop args 1] } + -progress { set state(-progress) [Pop args 1] } + -headers { set state(-headers) [Pop args 1] } + -- { Pop args ; break } + default { + return -code error "invalid option \"$option\":\ + must be one of [join [array names state] {, }]" + } + } + Pop args + } + + if {$state(-query) ne ""} { set state(method) POST } + set state(xmlhttp) [ole::ref createobject MSXML2.XMLHTTP] + $state(xmlhttp) open $state(method) $url True + foreach {hdr val} $state(-headers) { + $state(xmlhttp) setRequestHeader $hdr $val + } + $state(xmlhttp) send $state(-query) + if {$state(-command) eq {}} { + wait $token + } else { + watch $token + } + return $token +} + +proc ::ole::http::wait {token} { + upvar #0 $token state + watch $token + if {$state(state) eq "waiting"} { + ::vwait [::set token](state) + } +} + +proc ::ole::http::watch {token} { + variable watchlist + variable watchtimer + upvar #0 $token state + set state(begin) [clock seconds] + set state(state) waiting + after cancel $watchtimer + lappend watchlist $token + Poll +} + +proc ::ole::http::Poll {} { + variable watchlist + variable watchtimer + if {[llength $watchlist] > 0} { + set newlist {} + foreach token $watchlist { + upvar #0 $token state + if {$state(state) eq "waiting"} { + if {[$state(xmlhttp) readyState] == 4} { + set state(state) ok + set state(ncode) [$state(xmlhttp) status] + set state(code) [$state(xmlhttp) statusText] + set state(meta) {} + foreach line [split [$state(xmlhttp) getAllResponseHeaders] "\n"] { + if {[regexp {^([^:]+): ?(.*)} $line -> h v]} { + lappend state(meta) $h $v + } + } + set state(body) [$state(xmlhttp) responseText] + if {$state(-command) ne ""} { + if {[catch {eval $state(-command) $token} err]} { + ::bgerror $err + } + } + break + } + if {$state(-timeout) ne "" + && ([clock seconds] - $state(begin)) > $state(-timeout)} { + set state(state) timeout + $state(xmlhttp) abort + if {$state(-command) ne ""} { + if {[catch {eval $state(-command) $token} err]} { + ::bgerror $err + } + } + break + } + lappend newlist $token + } + } + set watchlist $newlist + if {[llength $watchlist] > 0} { + set watchtimer [after 200 [namespace origin Poll]] + } + } +} + +proc ::ole::http::status {token} { + upvar #0 $token state + return $state(state) +} +proc ::ole::http::data {token} { + upvar #0 $token state + return $state(body) +} +proc ::ole::http::ncode {token} { + upvar #0 $token state + return $state(ncode) +} +proc ::ole::http::code {token} { + upvar #0 $token state + return $state(code) +} +proc ::ole::http::meta {token} { + upvar #0 $token state + return $state(meta) +} +proc ::ole::http::cleanup {token} { + upvar #0 $token state + unset -nocomplain state +} +proc ::ole::http::Pop {varname {nth 0}} { + upvar $varname args + set r [lindex $args $nth] + set args [lreplace $args $nth $nth] + return $r +} + +package provide ole::http $::ole::http::version + +# ------------------------------------------------------------------------- +# Local Variables: +# indent-tabs-mode: nil +# End: diff --git a/src/bgeval.c b/src/bgeval.c new file mode 100644 index 0000000..db19980 --- /dev/null +++ b/src/bgeval.c @@ -0,0 +1,83 @@ +/* bgeval.c - Copyright (C) 2006 Pat Thoyts + * + * $Id$ + */ + +#include "tcloleInt.h" + +/* + * ---------------------------------------------------------------------- + * + * Ole_BackgroundEvalObjEx -- + * + * Evaluate a command while ensuring that we do not affect the + * interpreters state. This is important when evaluating script + * during background tasks. + * + * Results: + * A standard Tcl result code. + * + * Side Effects: + * The interpreters variables and code may be modified by the script + * but the result will not be modified. + * + * ---------------------------------------------------------------------- + */ + +int +Ole_BackgroundEvalObjv(Tcl_Interp *interp, int objc, Tcl_Obj *const *objv, + int flags) +{ + Tcl_DString errorInfo, errorCode; + Tcl_SavedResult state; + int r = TCL_OK; + + Tcl_DStringInit(&errorInfo); + Tcl_DStringInit(&errorCode); + + /* + * Record the state of the interpreter + */ + + Tcl_SaveResult(interp, &state); + Tcl_DStringAppend(&errorInfo, + Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY), -1); + Tcl_DStringAppend(&errorCode, + Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY), -1); + + /* + * Evaluate the command and handle any error. + */ + + r = Tcl_EvalObjv(interp, objc, objv, flags); + if (r == TCL_ERROR) { + Tcl_AddErrorInfo(interp, "\n (background event handler)"); + Tcl_BackgroundError(interp); + } + + /* + * Restore the state of the interpreter + */ + + Tcl_SetVar(interp, "errorInfo", + Tcl_DStringValue(&errorInfo), TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "errorCode", + Tcl_DStringValue(&errorCode), TCL_GLOBAL_ONLY); + Tcl_RestoreResult(interp, &state); + + /* + * Clean up references. + */ + + Tcl_DStringFree(&errorInfo); + Tcl_DStringFree(&errorCode); + + return r; +} + +/* + * Local variables: + * indent-tabs-mode: t + * tab-width: 8 + * End: + */ diff --git a/src/bind.c b/src/bind.c new file mode 100644 index 0000000..72167ff --- /dev/null +++ b/src/bind.c @@ -0,0 +1,79 @@ +/* bind.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" + + +int +OleBindCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +{ + HRESULT hr = S_OK; + OlePackageData *pkgPtr = clientData; + OleObjectData *dataPtr = NULL; + IConnectionPointContainer *containerPtr = NULL; + IConnectionPoint *connectionPtr = NULL; + IUnknown *sinkPtr = NULL; + DWORD cookie = 0; + int r = TCL_OK; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "object command ?interface_id?"); + return TCL_ERROR; + } + if (objv[1]->typePtr == tclTypes[tclCmdNameIndex]) { + dataPtr = GET_OLEREP(objv[1]); + } + if (dataPtr == NULL || dataPtr->magic != OLEDATAMAGIC) { + Tcl_SetResult(interp, "invalid argument: object must be a COM object", + TCL_STATIC); + return TCL_ERROR; + } + + /* + * Find the objects [default, source] interface + */ + + hr = dataPtr->dispatchPtr->lpVtbl->QueryInterface(dataPtr->dispatchPtr, + &IID_IConnectionPointContainer, (void **)&containerPtr); + if (SUCCEEDED(hr)) { + TYPEATTR *typeattrPtr = NULL; + hr = dataPtr->typeinfoPtr->lpVtbl->GetTypeAttr(dataPtr->typeinfoPtr, + &typeattrPtr); + if (SUCCEEDED(hr)) { + IID iid = typeattrPtr->guid; + hr = containerPtr->lpVtbl->FindConnectionPoint(containerPtr, + &iid, &connectionPtr); + if (SUCCEEDED(hr)) { + hr = connectionPtr->lpVtbl->Advise(connectionPtr, + sinkPtr, &cookie); + if (SUCCEEDED(hr)) { + /* + * add the sink cookie into a list of sinks + * so we can unadvise at some point + */ + } + } + dataPtr->typeinfoPtr->lpVtbl->ReleaseTypeAttr(dataPtr->typeinfoPtr, + typeattrPtr); + } + } + if (FAILED(hr)) { + r = Ole_SetObjResult(interp, "bind", hr); + } + return r; +} + +/* + * Local variables: + * indent-tabs-mode: t + * tab-width: 8 + * End: + */ diff --git a/src/coimpl.c b/src/coimpl.c new file mode 100644 index 0000000..b6171a7 --- /dev/null +++ b/src/coimpl.c @@ -0,0 +1,224 @@ +/* coimpl.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" + +typedef struct OleInterpCom { + IDispatchVtbl *lpVtbl; + ISupportErrorInfoVtbl *lpVtbl2; + long refcount; + Tcl_Interp *interp; +} OleInterpCom; + +static void OleInterpComDestroy(OleInterpCom *this); + +static STDMETHODIMP +OleInterpCom_QueryInterface(IDispatch *This, REFIID riid, void **ppv) +{ + HRESULT hr = E_NOINTERFACE; + OleInterpCom *this = (OleInterpCom *)This; + *ppv = NULL; + if (memcmp(riid, &IID_IUnknown, sizeof(IID)) == 0 + || memcmp(riid, &IID_IDispatch, sizeof(IID)) == 0) { + *ppv = (void **)this; + this->lpVtbl->AddRef(This); + hr = S_OK; + } else if (memcmp(riid, &IID_ISupportErrorInfo, sizeof(IID)) == 0) { + *ppv = (void **)(this + 1); + this->lpVtbl2->AddRef((ISupportErrorInfo *)(this + 1)); + hr = S_OK; + } + return hr; +} + +static STDMETHODIMP_(ULONG) +OleInterpCom_AddRef(IDispatch *This) +{ + OleInterpCom *this = (OleInterpCom *)This; + return InterlockedIncrement(&this->refcount); +} + +static STDMETHODIMP_(ULONG) +OleInterpCom_Release(IDispatch *This) +{ + OleInterpCom *this = (OleInterpCom *)This; + long r = 0; + if ((r = InterlockedDecrement(&this->refcount)) == 0) { + OleInterpComDestroy(this); + } + return r; +} + +static STDMETHODIMP +OleInterpCom_GetTypeInfoCount(IDispatch *This, UINT *pctinfo) +{ + HRESULT hr = E_POINTER; + if (pctinfo != NULL) { + *pctinfo = 0; + hr = S_OK; + } + return hr; +} + +static STDMETHODIMP +OleInterpCom_GetTypeInfo(IDispatch *This, UINT iTypeInfo, + LCID lcid, ITypeInfo **ppTypeInfo) +{ + HRESULT hr = E_POINTER; + if (ppTypeInfo) { + *ppTypeInfo = NULL; + hr = E_NOTIMPL; + } + return hr; +} + +static STDMETHODIMP +OleInterpCom_GetIDsOfNames(IDispatch *This, REFIID riid, LPOLESTR *rgszNames, + UINT cNames, LCID lcid, DISPID *rgDispid) +{ + OleInterpCom *this = (OleInterpCom *)This; + Tcl_CmdInfo info; + HRESULT hr = E_POINTER; + if (rgDispid) { + Tcl_DString ds; + Tcl_DStringInit(&ds); + Tcl_UniCharToUtfDString(rgszNames[0], + Tcl_UniCharLen(rgszNames[0]), &ds); + if (!Tcl_GetCommandInfo(this->interp, Tcl_DStringValue(&ds), &info)) { + return DISP_E_UNKNOWNNAME; + } + *rgDispid = info.isNativeObjectProc + ? (DISPID)info.objProc : (DISPID)info.proc; + Tcl_DStringFree(&ds); + hr = S_OK; + } + + return E_NOTIMPL; +} + +static STDMETHODIMP +OleInterpCom_Invoke(IDispatch *This, DISPID dispidMember, REFIID riid, + LCID lcid, WORD wFlags, DISPPARAMS *dpPtr, + VARIANT *varPtr, EXCEPINFO *eiPtr, UINT *argerrPtr) +{ + OleInterpCom *this = (OleInterpCom *)This; + HRESULT hr = S_OK; + Tcl_Obj **objv; + unsigned int n; + int objc; + + if (memcmp(riid, &IID_NULL, sizeof(IID)) != 0) { + return E_FAIL; + } + if (dpPtr->cNamedArgs != 0) { + return E_FAIL; + } + objc = dpPtr->cArgs; + objv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * objc); + for (n = 0; SUCCEEDED(hr) && n < dpPtr->cArgs; ++n) { + hr = OleVariantObj(this->interp, &dpPtr->rgvarg[objc-n-1], &objv[n]); + if (SUCCEEDED(hr)) { + Tcl_IncrRefCount(objv[n]); + } + } + if (FAILED(hr)) { + // cleanup the objv + return E_INVALIDARG; + } + if (Ole_BackgroundEvalObjv(this->interp, objc, objv, TCL_EVAL_GLOBAL) != TCL_OK) { + // handle errors. + } + return S_OK; +} + +static STDMETHODIMP +ISupportErrorInfo_QueryInterface(ISupportErrorInfo *This, + REFIID riid, void **ppv) +{ + OleInterpCom *this = (OleInterpCom *)(This - 1); + return this->lpVtbl->QueryInterface((IDispatch *)this, riid, ppv); +} + +static STDMETHODIMP_(ULONG) +ISupportErrorInfo_AddRef(ISupportErrorInfo *This) +{ + OleInterpCom *this = (OleInterpCom *)(This - 1); + return this->lpVtbl->AddRef((IDispatch *)this); +} + +static STDMETHODIMP_(ULONG) +ISupportErrorInfo_Release(ISupportErrorInfo *This) +{ + OleInterpCom *this = (OleInterpCom *)(This - 1); + return this->lpVtbl->AddRef((IDispatch *)this); +} + +static STDMETHODIMP +ISupportErrorInfo_InterfaceSupportsErrorInfo(ISupportErrorInfo *This, + REFIID riid) +{ + if (memcmp(riid, &IID_IDispatch, sizeof(IID) == 0)) { + return S_OK; + } + return S_FALSE; +} + +static void +OleInterpComDestroy(OleInterpCom *this) +{ + CoTaskMemFree(this); +} + +HRESULT +Ole_CreateComInstance(Tcl_Interp *interp, REFIID riid, void **unkPtrPtr) +{ + static IDispatchVtbl vtbl = { + OleInterpCom_QueryInterface, + OleInterpCom_AddRef, + OleInterpCom_Release, + OleInterpCom_GetTypeInfoCount, + OleInterpCom_GetTypeInfo, + OleInterpCom_GetIDsOfNames, + OleInterpCom_Invoke, + }; + static ISupportErrorInfoVtbl vtbl2 = { + ISupportErrorInfo_QueryInterface, + ISupportErrorInfo_AddRef, + ISupportErrorInfo_Release, + ISupportErrorInfo_InterfaceSupportsErrorInfo, + }; + OleInterpCom *comPtr = NULL; + HRESULT hr = E_POINTER; + if (unkPtrPtr) { + *unkPtrPtr = NULL; + hr = E_OUTOFMEMORY; + comPtr = (OleInterpCom *)CoTaskMemAlloc(sizeof(OleInterpCom)); + if (comPtr) { + comPtr->lpVtbl = &vtbl; + comPtr->lpVtbl2 = &vtbl2; + comPtr->refcount = 0; + comPtr->interp = interp; + hr = comPtr->lpVtbl->QueryInterface((IDispatch *)comPtr, + riid, unkPtrPtr); + if (FAILED(hr)) { + CoTaskMemFree(comPtr); + comPtr = NULL; + } + } + } + return hr; +} + +/* + * Local variables: + * indent-tabs-mode: t + * tab-width: 8 + * End: + */ diff --git a/src/foreach.c b/src/foreach.c index 8e13fc4..8841d73 100644 --- a/src/foreach.c +++ b/src/foreach.c @@ -11,11 +11,12 @@ #include "tcloleInt.h" static int -EvalBody(Tcl_Interp *interp, Tcl_Obj *varnameObj, VARIANT v, Tcl_Obj *bodyObj) +EvalBody(Tcl_Interp *interp, Tcl_Obj *varnameObj, + VARIANT *vPtr, Tcl_Obj *bodyObj) { int r = TCL_ERROR; Tcl_Obj *varObj = NULL; - HRESULT hr = OleVariantObj(interp, v, &varObj); + HRESULT hr = OleVariantObj(interp, vPtr, &varObj); if (SUCCEEDED(hr)) { Tcl_Obj *setObj = Tcl_ObjSetVar2(interp, varnameObj, NULL, varObj, TCL_LEAVE_ERR_MSG); @@ -73,7 +74,7 @@ OleForeachCmd(ClientData clientData, Tcl_Interp *interp, 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]); + r = EvalBody(interp, objv[1], &rgVar[n], objv[3]); if (!(r == TCL_OK || r == TCL_CONTINUE)) { break; } diff --git a/src/invoke.c b/src/invoke.c index 89099e3..76d861f 100644 --- a/src/invoke.c +++ b/src/invoke.c @@ -10,47 +10,128 @@ #include "tcloleInt.h" -HRESULT -OleVariantObj(Tcl_Interp *interp, VARIANT v, Tcl_Obj **resultPtrPtr) +static HRESULT +SafeArrayToObj(Tcl_Interp *interp, + SAFEARRAY *saPtr, int dim, Tcl_Obj **resultPtrPtr) { HRESULT hr = S_OK; + VARTYPE vt; + int n, dims, lower, upper; + dims = SafeArrayGetDim(saPtr); + hr = SafeArrayGetVartype(saPtr, &vt); + hr = SafeArrayGetLBound(saPtr, dim, &lower); + hr = SafeArrayGetUBound(saPtr, dim, &upper); + if (dim < dims) { + *resultPtrPtr = Tcl_NewListObj(0, NULL); + for (n = lower; n <= upper; ++n) { + Tcl_Obj *eltObj = NULL; + hr = SafeArrayToObj(interp, saPtr, dim+1, &eltObj); + Tcl_ListObjAppendElement(interp, *resultPtrPtr, eltObj); + } + return hr; + } - /* - * FIX ME: Needs to handle VT_ARRAY and VT_BYREF flags - */ + if (vt == VT_UI1 && dims == 1) { + unsigned char *dataPtr = NULL; + hr = SafeArrayAccessData(saPtr, (void **)&dataPtr); + if (SUCCEEDED(hr)) { + *resultPtrPtr = Tcl_NewByteArrayObj(dataPtr, (upper - lower + 1)); + SafeArrayUnaccessData(saPtr); + } + } else if (vt == VT_R8) { + double *dataPtr = NULL; + Tcl_Obj *listObj = Tcl_NewListObj(0, NULL); + hr = SafeArrayAccessData(saPtr, (void **)&dataPtr); + if (SUCCEEDED(hr)) { + for (n = lower; SUCCEEDED(hr) && n <= upper; ++n, ++dataPtr) { + Tcl_Obj *eltObj = Tcl_NewDoubleObj(*dataPtr); + Tcl_ListObjAppendElement(interp, listObj, eltObj); + } + SafeArrayUnaccessData(saPtr); + } + *resultPtrPtr = listObj; + } else if (vt == VT_VARIANT) { + VARIANT *varPtr = NULL; + Tcl_Obj *listObj = Tcl_NewListObj(0, NULL); + hr = SafeArrayAccessData(saPtr, (void **)&varPtr); + if (SUCCEEDED(hr)) { + for (n = lower; SUCCEEDED(hr) && n <= upper; ++n, ++varPtr) { + Tcl_Obj *eltObj = NULL; + hr = OleVariantObj(interp, varPtr, &eltObj); + if (SUCCEEDED(hr)) { + Tcl_ListObjAppendElement(interp, listObj, eltObj); + } + } + SafeArrayUnaccessData(saPtr); + } + *resultPtrPtr = listObj; + } else { + hr = E_INVALIDARG; + } + return hr; +} + +HRESULT +OleVariantObj(Tcl_Interp *interp, const VARIANT *vPtr, Tcl_Obj **resultPtrPtr) +{ + HRESULT hr = S_OK; + VARIANT vv; - switch (v.vt) { + if (V_ISARRAY(vPtr)) { + VARTYPE vt = V_VT(vPtr) & VT_TYPEMASK; + SAFEARRAY *saPtr = V_ISBYREF(vPtr) ? *V_ARRAYREF(vPtr) : V_ARRAY(vPtr); + return SafeArrayToObj(interp, saPtr, 1, resultPtrPtr); + } + + switch (V_VT(vPtr)) { case VT_BOOL: - *resultPtrPtr = Tcl_NewBooleanObj((v.boolVal != VARIANT_FALSE)); + *resultPtrPtr = Tcl_NewBooleanObj((V_BOOL(vPtr) != VARIANT_FALSE)); + break; + case VT_I1: case VT_UI1: + *resultPtrPtr = Tcl_NewIntObj(V_I1(vPtr)); break; - case VT_I2: - *resultPtrPtr = Tcl_NewIntObj(v.iVal); + case VT_I2: case VT_UI2: + *resultPtrPtr = Tcl_NewIntObj(V_I2(vPtr)); break; - case VT_I4: - *resultPtrPtr = Tcl_NewLongObj(v.lVal); + case VT_I4: case VT_UI4: case VT_INT: case VT_UINT: + *resultPtrPtr = Tcl_NewLongObj(V_I4(vPtr)); + break; + case VT_I8: case VT_UI8: + *resultPtrPtr = Tcl_NewWideIntObj(V_I8(vPtr)); break; case VT_R4: - *resultPtrPtr = Tcl_NewDoubleObj(v.fltVal); + *resultPtrPtr = Tcl_NewDoubleObj(V_R4(vPtr)); break; - case VT_R8: - *resultPtrPtr = Tcl_NewDoubleObj(v.dblVal); + case VT_R8: + *resultPtrPtr = Tcl_NewDoubleObj(V_R8(vPtr)); break; case VT_UNKNOWN: - hr = VariantChangeType(&v, &v, 0, VT_DISPATCH); - if (SUCCEEDED(hr)) - *resultPtrPtr = Ole_NewOleObj(interp, v.pdispVal); + VariantInit(&vv); + hr = VariantChangeType(&vv, (VARIANT *)vPtr, 0, VT_DISPATCH); + if (SUCCEEDED(hr)) { + *resultPtrPtr = Ole_NewOleObj(interp, V_DISPATCH(&vv)); + VariantClear(&vv); + } break; case VT_DISPATCH: - *resultPtrPtr = Ole_NewOleObj(interp, v.pdispVal); + *resultPtrPtr = Ole_NewOleObj(interp, V_DISPATCH(vPtr)); + break; + case VT_DISPATCH | VT_BYREF: + if (V_DISPATCHREF(vPtr) != NULL) + *resultPtrPtr = Ole_NewOleObj(interp, *V_DISPATCHREF(vPtr)); break; - case VT_CY: case VT_DATE: case VT_DECIMAL: + case VT_CY: case VT_DECIMAL: case VT_DATE: case VT_VARIANT: - /* *resultPtrPtr = Ole_NewVariantObj(v);*/ + /* *resultPtrPtr = Ole_NewVariantObj(vPtr);*/ /* break; */ default: { - hr = VariantChangeType(&v, &v, VARIANT_ALPHABOOL, VT_BSTR); - if (SUCCEEDED(hr)) - *resultPtrPtr = Tcl_NewUnicodeObj(v.bstrVal, -1); + VARIANT vv; + VariantInit(&vv); + hr = VariantChangeType(&vv, (VARIANT *)vPtr, VARIANT_ALPHABOOL, VT_BSTR); + if (SUCCEEDED(hr)) { + *resultPtrPtr = Tcl_NewUnicodeObj(V_BSTR(&vv), SysStringLen(V_BSTR(&vv))); + VariantClear(&vv); + } } } return hr; @@ -59,9 +140,9 @@ OleVariantObj(Tcl_Interp *interp, VARIANT v, Tcl_Obj **resultPtrPtr) static DISPPARAMS * OleDispParamsCreate(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { - OlePackageData *pkgPtr; - DISPPARAMS * dp; - int cn; + OlePackageData *pkgPtr = NULL; + DISPPARAMS * dp = NULL; + int cn = 0; pkgPtr = Tcl_GetAssocData(interp, "ole::package", NULL); @@ -107,9 +188,17 @@ OleDispParamsCreate(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) } } if (argPtr->vt == VT_EMPTY) { - LPCOLESTR olestr = Tcl_GetUnicode(objPtr); - argPtr->bstrVal = SysAllocString(olestr); + LPOLESTR olestr = NULL; + Tcl_DString ds; + int len = 0, len_ucs = 0; + const char *str = Tcl_GetStringFromObj(objPtr, &len); + Tcl_DStringInit(&ds); + Tcl_UtfToUniCharDString(str, len, &ds); + len_ucs = Tcl_UniCharLen((const Tcl_UniChar *)Tcl_DStringValue(&ds)); + olestr = (LPOLESTR)Tcl_DStringValue(&ds); + argPtr->bstrVal = SysAllocStringLen(olestr, len_ucs); argPtr->vt = VT_BSTR; + Tcl_DStringFree(&ds); } } } @@ -156,8 +245,10 @@ OleObjectInvoke(ClientData clientData, Tcl_Interp *interp, VARIANT v; EXCEPINFO ei; DISPPARAMS *dp = NULL; - UINT uierr; + UINT uierr = 0; + ZeroMemory(&ei, sizeof(ei)); + ZeroMemory(&v, sizeof(v)); VariantInit(&v); dp = OleDispParamsCreate(interp, objc-2, objv+2); @@ -179,7 +270,7 @@ OleObjectInvoke(ClientData clientData, Tcl_Interp *interp, OleDispParamsFree(dp); if (SUCCEEDED(hr)) { Tcl_Obj *resultObj = Ole_NewVariantObj(v); - hr = OleVariantObj(interp, v, &resultObj); + hr = OleVariantObj(interp, &v, &resultObj); if (SUCCEEDED(hr)) { Tcl_SetObjResult(interp, resultObj); } diff --git a/src/tclole.c b/src/tclole.c index 92bfc18..0de8688 100644 --- a/src/tclole.c +++ b/src/tclole.c @@ -212,6 +212,11 @@ OlePackageDataDelete(ClientData clientData, Tcl_Interp *interp) { OlePackageData *pkgPtr = clientData; Tcl_DeleteHashTable(&pkgPtr->table); + if (pkgPtr->selfPtr) { + /* RevokeActiveObject(pkgPtr->activeid, NULL);*/ + pkgPtr->selfPtr->lpVtbl->Release(pkgPtr->selfPtr); + pkgPtr->selfPtr = NULL; + } ckfree(clientData); } @@ -253,10 +258,14 @@ Ole_Init(Tcl_Interp *interp) tclTypes[tclCmdNameIndex] = Tcl_GetObjType("cmdName"); OleObjInit(interp); + Ole_CreateComInstance(interp, &IID_IDispatch, &pkgPtr->selfPtr); + /* RegisterActiveObject((IUnknown *)pkgPtr->selfPtr, &clsid, + ACTIVEOBJECT_WEAK, &pkgPtr->activeid); */ /* create commands */ Tcl_CreateObjCommand(interp, "ole::ref", RefCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "ole::foreach", OleForeachCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "ole::bind", OleBindCmd, (ClientData)pkgPtr, NULL); Tcl_PkgProvideEx(interp, PACKAGE_NAME, PACKAGE_VERSION, NULL); return TCL_OK; diff --git a/src/tcloleInt.h b/src/tcloleInt.h index 6eff8ef..6c3dc27 100644 --- a/src/tcloleInt.h +++ b/src/tcloleInt.h @@ -15,6 +15,7 @@ #define WIN32_LEAN_AND_MEAN #include #include +#include #include #include "tclole.h" @@ -42,6 +43,8 @@ typedef struct OlePackageData { size_t uid; Tcl_HashTable table; + IDispatch *selfPtr; + unsigned long activeid; } OlePackageData; #define OLEDATAMAGIC 0x01656C6FUL @@ -83,13 +86,19 @@ extern Tcl_ObjType tclVariantType; #define OLE_TRACE LocalTrace #endif /* _DEBUG */ +int Ole_BackgroundEvalObjv(Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv, int flags); int OleForeachCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +HRESULT Ole_CreateComInstance(Tcl_Interp *interp, + REFIID riid, void **unkPtrPtr); +int OleBindCmd(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, +HRESULT OleVariantObj(Tcl_Interp *interp, const VARIANT *v, Tcl_Obj **resultPtrPtr); /* oleobj.c */ diff --git a/win/makefile.vc b/win/makefile.vc index c1d5095..e999588 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -164,12 +164,15 @@ PROJECT = tclole #PROJECT_REQUIRES_TK=1 !include "rules.vc" -DOTVERSION = 0.2 +DOTVERSION = 0.3 VERSION = $(DOTVERSION:.=) STUBPREFIX = $(PROJECT)stub DLLOBJS = \ $(TMP_DIR)\tclole.obj \ + $(TMP_DIR)\bind.obj \ + $(TMP_DIR)\bgeval.obj \ + $(TMP_DIR)\coimpl.obj \ $(TMP_DIR)\foreach.obj\ $(TMP_DIR)\invoke.obj \ $(TMP_DIR)\oleobj.obj \ @@ -216,7 +219,7 @@ COMPATDIR = $(ROOT)\compat !if !$(DEBUG) !if $(OPTIMIZING) ### This cranks the optimization level to maximize speed -cdebug = $(OPTIMIZATIONS) +cdebug = -Zi $(OPTIMIZATIONS) !else cdebug = !endif @@ -265,12 +268,12 @@ TCL_CFLAGS = -DPACKAGE_NAME="\"$(PROJECT)\"" \ #--------------------------------------------------------------------- !if $(DEBUG) -ldebug = -debug:full -debugtype:cv +ldebug = -debug !if $(MSVCRT) ldebug = $(ldebug) -nodefaultlib:msvcrt !endif !else -ldebug = -release -opt:ref -opt:icf,3 +ldebug = -debug -opt:ref -opt:icf,3 !endif ### Declarations common to all linker options -- 2.23.0