From 18fe12cf8fa35989e68e1356e857dfbc576ccd24 Mon Sep 17 00:00:00 2001 From: Pat Thoyts Date: Wed, 19 Dec 2007 13:02:34 +0000 Subject: [PATCH] Implemented the self object callback and -get/-set for method calls --- configure | 18 ++++---- configure.in | 2 +- src/bind.c | 2 +- src/coimpl.c | 120 ++++++++++++++++++++++++++++++++++++++++-------- src/invoke.c | 25 +++++++++- win/makefile.vc | 2 +- 6 files changed, 136 insertions(+), 33 deletions(-) diff --git a/configure b/configure index cade0c0..8930433 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.3. +# Generated by GNU Autoconf 2.59 for tclole 0.4. # # 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.3' -PACKAGE_STRING='tclole 0.3' +PACKAGE_VERSION='0.4' +PACKAGE_STRING='tclole 0.4' 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.3 to adapt to many kinds of systems. +\`configure' configures tclole 0.4 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.3:";; + short | recursive ) echo "Configuration of tclole 0.4:";; 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.3 +tclole configure 0.4 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.3, which was +It was created by tclole $as_me 0.4, 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.3, which was +This file was extended by tclole $as_me 0.4, 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.3 +tclole config.status 0.4 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 5791063..5af7982 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.3]) +AC_INIT([tclole], [0.4]) #-------------------------------------------------------------------- # Call TEA_INIT as the first TEA_ macro to set up initial vars. diff --git a/src/bind.c b/src/bind.c index 23f1fb1..9f78e6e 100644 --- a/src/bind.c +++ b/src/bind.c @@ -54,7 +54,7 @@ OleBindCmd(ClientData clientData, Tcl_Interp *interp, /* create a Tcl sink instance */ hr = Ole_CreateComInstance(interp, objv[2], - &IID_IUnknown, sinkPtr); + &IID_IUnknown, &sinkPtr); if (SUCCEEDED(hr)) { DWORD cookie = 0; diff --git a/src/coimpl.c b/src/coimpl.c index 2776aa5..a7f9ed0 100644 --- a/src/coimpl.c +++ b/src/coimpl.c @@ -14,8 +14,10 @@ typedef struct OleInterpCom { IDispatchVtbl *lpVtbl; ISupportErrorInfoVtbl *lpVtbl2; long refcount; + unsigned long maxid; Tcl_Interp *interp; Tcl_Obj *cmdObj; + Tcl_HashTable table; } OleInterpCom; static void OleInterpComDestroy(OleInterpCom *this); @@ -85,23 +87,95 @@ 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) { + int isnew = 0; + Tcl_HashEntry *entryPtr = NULL; 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; + entryPtr = Tcl_CreateHashEntry(&this->table, Tcl_DStringValue(&ds), &isnew); + if (isnew) { + *rgDispid = this->maxid++; + Tcl_SetHashValue(entryPtr, *rgDispid); + } else { + *rgDispid = (DISPID)Tcl_GetHashValue(entryPtr); + } Tcl_DStringFree(&ds); hr = S_OK; } - return E_NOTIMPL; + return hr; +} + +/* + * Evaluate some script in our interpreter without disrupting the current interpreter + * error state. Any error information is returned to the caller and the + * interp left as it was. + */ + +static HRESULT +EvalObjv(Tcl_Interp *interp, int objc, Tcl_Obj *const *objv, EXCEPINFO *eiPtr) +{ + HRESULT hr = S_OK; + 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, TCL_EVAL_GLOBAL); + if (r == TCL_ERROR) { + if (eiPtr) { + Tcl_DString ds; + Tcl_Obj *resObj = Tcl_GetObjResult(interp); + Tcl_DStringInit(&ds); + Tcl_UtfToUniCharDString(Tcl_GetString(objv[0]), -1, &ds); + ZeroMemory(eiPtr, sizeof(EXCEPINFO)); + eiPtr->bstrSource = SysAllocString((Tcl_UniChar *)Tcl_DStringValue(&ds)); + eiPtr->bstrDescription = SysAllocString(Tcl_GetUnicode(resObj)); + Tcl_DStringFree(&ds); + eiPtr->scode = E_FAIL; + hr = DISP_E_EXCEPTION; + } else { + hr = E_FAIL; + } + } + + /* + * 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; } static STDMETHODIMP @@ -110,10 +184,10 @@ OleInterpCom_Invoke(IDispatch *This, DISPID dispidMember, REFIID riid, VARIANT *varPtr, EXCEPINFO *eiPtr, UINT *argerrPtr) { OleInterpCom *this = (OleInterpCom *)This; + Tcl_HashEntry *entryPtr = NULL; HRESULT hr = S_OK; Tcl_Obj **objv; - unsigned int n; - int objc; + unsigned int n, objc = 0; if (memcmp(riid, &IID_NULL, sizeof(IID)) != 0) { return E_FAIL; @@ -121,22 +195,27 @@ OleInterpCom_Invoke(IDispatch *This, DISPID dispidMember, REFIID riid, if (dpPtr->cNamedArgs != 0) { return E_FAIL; } - objc = dpPtr->cArgs; - objv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * objc); + + objv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * (dpPtr->cArgs + 2)); + objv[objc] = this->cmdObj; + Tcl_IncrRefCount(objv[objc++]); + objv[objc] = Tcl_NewIntObj(dispidMember); + Tcl_IncrRefCount(objv[objc++]); + for (n = 0; SUCCEEDED(hr) && n < dpPtr->cArgs; ++n) { - hr = OleVariantObj(this->interp, &dpPtr->rgvarg[objc-n-1], &objv[n]); + hr = OleVariantObj(this->interp, &dpPtr->rgvarg[dpPtr->cArgs - n - 1], &objv[objc]); if (SUCCEEDED(hr)) { - Tcl_IncrRefCount(objv[n]); + Tcl_IncrRefCount(objv[objc]); } + ++objc; } - if (FAILED(hr)) { - // cleanup the objv - return E_INVALIDARG; + if (SUCCEEDED(hr)) { + hr = EvalObjv(this->interp, objc, objv, eiPtr); } - if (Ole_BackgroundEvalObjv(this->interp, objc, objv, TCL_EVAL_GLOBAL) != TCL_OK) { - // handle errors. + for (n = 0; n < objc; ++n) { + Tcl_DecrRefCount(objv[n]); } - return S_OK; + return hr; } static STDMETHODIMP @@ -174,6 +253,7 @@ ISupportErrorInfo_InterfaceSupportsErrorInfo(ISupportErrorInfo *This, static void OleInterpComDestroy(OleInterpCom *this) { + Tcl_DeleteHashTable(&this->table); Tcl_DecrRefCount(this->cmdObj); Tcl_Release(this->interp); CoTaskMemFree(this); @@ -208,10 +288,12 @@ Ole_CreateComInstance(Tcl_Interp *interp, Tcl_Obj *cmdObj, comPtr->lpVtbl = &vtbl; comPtr->lpVtbl2 = &vtbl2; comPtr->refcount = 0; + comPtr->maxid = 1; comPtr->interp = interp; comPtr->cmdObj = Tcl_DuplicateObj(cmdObj); Tcl_IncrRefCount(comPtr->cmdObj); Tcl_Preserve(comPtr->interp); + Tcl_InitHashTable(&comPtr->table, TCL_STRING_KEYS); hr = comPtr->lpVtbl->QueryInterface((IDispatch *)comPtr, riid, unkPtrPtr); if (FAILED(hr)) { diff --git a/src/invoke.c b/src/invoke.c index 45d0ee8..1a9ec01 100644 --- a/src/invoke.c +++ b/src/invoke.c @@ -262,14 +262,35 @@ OleObjectInvoke(ClientData clientData, Tcl_Interp *interp, HRESULT hr; DISPID dispid; LPWSTR name; + int narg = 1, optindex = 0; WORD mode = DISPATCH_PROPERTYGET | DISPATCH_METHOD; + enum {OLEINVOKE_GET, OLEINVOKE_PUT, OLEINVOKE_SET, OLEINVOKE_METHOD, OLEINVOKE_BREAK}; + const char *optionNames[] = { + "-get", "-put", "-set", "-method", "--", NULL + }; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "name ?arg ...?"); return TCL_ERROR; } - name = Tcl_GetUnicode(objv[1]); + for (narg = 1; narg < objc; ++narg) { + if (Tcl_GetIndexFromObj(interp, objv[narg], optionNames, "option", 0, &optindex) != TCL_OK) { + break; + } + if (optindex == OLEINVOKE_BREAK) { + ++narg; + break; + } + switch (optindex) { + case OLEINVOKE_GET: mode = DISPATCH_PROPERTYGET; break; + case OLEINVOKE_SET: mode = DISPATCH_PROPERTYPUTREF; break; + case OLEINVOKE_PUT: mode = DISPATCH_PROPERTYPUT; break; + case OLEINVOKE_METHOD: mode = DISPATCH_METHOD; break; + } + } + + name = Tcl_GetUnicode(objv[narg]); if (dataPtr->typeinfoPtr) { hr = dataPtr->typeinfoPtr->lpVtbl->GetIDsOfNames(dataPtr->typeinfoPtr, &name, 1, (MEMBERID *)&dispid); @@ -287,7 +308,7 @@ OleObjectInvoke(ClientData clientData, Tcl_Interp *interp, ZeroMemory(&ei, sizeof(ei)); ZeroMemory(&v, sizeof(v)); VariantInit(&v); - dp = OleDispParamsCreate(interp, objc-2, objv+2); + dp = OleDispParamsCreate(interp, objc-(narg+1), objv+(narg+1)); if ((mode & DISPATCH_PROPERTYPUT) || (mode & DISPATCH_PROPERTYPUTREF)) { static DISPID putid = DISPID_PROPERTYPUT; diff --git a/win/makefile.vc b/win/makefile.vc index 6619fde..ceb0ea7 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -164,7 +164,7 @@ PROJECT = tclole #PROJECT_REQUIRES_TK=1 !include "rules.vc" -DOTVERSION = 0.3 +DOTVERSION = 0.4 VERSION = $(DOTVERSION:.=) STUBPREFIX = $(PROJECT)stub -- 2.23.0