#! /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
# 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.
# 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]...
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
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.
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 $@
} >&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
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'`\\"
# 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.
--- /dev/null
+# http.tcl - 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$
+#
+
+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:
--- /dev/null
+/* bgeval.c - Copyright (C) 2006 Pat Thoyts <patthoyts@users.sourceforge.net>
+ *
+ * $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:
+ */
--- /dev/null
+/* bind.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"
+
+
+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:
+ */
--- /dev/null
+/* coimpl.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"
+
+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:
+ */
#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);
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;
}
#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;
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);
}
}
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);
}
}
}
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);
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);
}
{
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);
}
\f
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;
#define WIN32_LEAN_AND_MEAN
#include <windows.h>
#include <ole2.h>
+#include <ocidl.h>
#include <assert.h>
#include "tclole.h"
{
size_t uid;
Tcl_HashTable table;
+ IDispatch *selfPtr;
+ unsigned long activeid;
} OlePackageData;
#define OLEDATAMAGIC 0x01656C6FUL
#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 */
#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 \
!if !$(DEBUG)
!if $(OPTIMIZING)
### This cranks the optimization level to maximize speed
-cdebug = $(OPTIMIZATIONS)
+cdebug = -Zi $(OPTIMIZATIONS)
!else
cdebug =
!endif
#---------------------------------------------------------------------
!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
projects / tclole / commitdiff