From ccf15b779ff3bb1882fbb3511f837d99e82e3d00 Mon Sep 17 00:00:00 2001 From: Pat Thoyts Date: Wed, 23 Jan 2008 09:36:03 +0000 Subject: [PATCH] Added ole::type for inspecting tcl object types. Added ole::ref self for passing an IDispatch to a tcl procedure. Made use of the variant tcl type Improvements to the http package. --- library/http.tcl | 38 ++++++++++++++++++++++++++------ src/coimpl.c | 32 ++++++++++++++++----------- src/invoke.c | 12 ++++++++--- src/tclole.c | 1 + src/tcloleInt.h | 6 ++++-- src/varobj.c | 56 +++++++++++++++++++++++++++++++++++++++++------- win/nmakehlp.c | 10 ++++++++- win/rules.vc | 12 ++++++++--- 8 files changed, 131 insertions(+), 36 deletions(-) diff --git a/library/http.tcl b/library/http.tcl index 6b89d95..545b93d 100644 --- a/library/http.tcl +++ b/library/http.tcl @@ -11,7 +11,7 @@ package require tclole namespace eval ::ole::http { - variable version 1.1.0 + variable version 1.2.0 variable watchlist {} variable watchtimer {} @@ -42,8 +42,16 @@ proc ::ole::http::geturl {url args} { } if {$state(-query) ne ""} { set state(method) POST } - set state(xmlhttp) [ole::ref createobject MSXML2.XMLHTTP] + set state(xmlhttp) "" + foreach progid {MSXML2.XMLHTTP.6.0 MSXML2.XMLHTTP.5.0 MSXML2.XMLHTTP.4.0 \ + MSXML2.XMLHTTP.3.0 MSXML2.XMLHTTP.2.6 Microsoft.XMLHTTP} { + if {![catch {set state(xmlhttp) [ole::ref createobject MSXML2.XMLHTTP]}]} { + break + } + } + if {$state(xmlhttp) eq {}} { return -code error "error: no suitable XMLHttp object available" } $state(xmlhttp) open $state(method) $url True + $state(xmlhttp) -put onreadystatechange [ole::ref self [list [namespace origin Callback] $token]] foreach {hdr val} $state(-headers) { $state(xmlhttp) setRequestHeader $hdr $val } @@ -55,7 +63,15 @@ proc ::ole::http::geturl {url args} { } return $token } - + +proc ::ole::http::Callback {token dispid args} { + # replace the polling stuff with a check of ... + upvar #0 $token state + if {[$state(xmlhttp) readyState] == 4} { + # do stuff + } +} + proc ::ole::http::wait {token} { upvar #0 $token state watch $token @@ -90,7 +106,7 @@ proc ::ole::http::Poll {} { set state(meta) {} foreach line [split [$state(xmlhttp) getAllResponseHeaders] "\n"] { if {[regexp {^([^:]+): ?(.*)} $line -> h v]} { - lappend state(meta) $h $v + lappend state(meta) $h [string trimright $v] } } if {$state(-command) ne ""} { @@ -145,9 +161,19 @@ proc ::ole::http::code {token} { upvar #0 $token state return $state(code) } -proc ::ole::http::meta {token} { +proc ::ole::http::meta {token {header {}}} { upvar #0 $token state - return $state(meta) + if {$header ne {}} { + set header [string tolower $header] + foreach {h v} $state(meta) { + if {[string equal $header [string tolower $h]]} { + return $v + } + } + } else { + return $state(meta) + } + return {} } proc ::ole::http::cleanup {token} { upvar #0 $token state diff --git a/src/coimpl.c b/src/coimpl.c index a7f9ed0..b3c144c 100644 --- a/src/coimpl.c +++ b/src/coimpl.c @@ -186,8 +186,8 @@ OleInterpCom_Invoke(IDispatch *This, DISPID dispidMember, REFIID riid, OleInterpCom *this = (OleInterpCom *)This; Tcl_HashEntry *entryPtr = NULL; HRESULT hr = S_OK; - Tcl_Obj **objv; - unsigned int n, objc = 0; + Tcl_Obj **objv, **tmpv; + unsigned int n, objc = 0, tmpc = 0; if (memcmp(riid, &IID_NULL, sizeof(IID)) != 0) { return E_FAIL; @@ -196,25 +196,31 @@ OleInterpCom_Invoke(IDispatch *This, DISPID dispidMember, REFIID riid, return E_FAIL; } - 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++]); + /* append dispid and the variant args to the command list */ + Tcl_ListObjGetElements(NULL, this->cmdObj, &objc, &objv); + tmpv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * (objc + dpPtr->cArgs + 1)); + for (tmpc = 0; tmpc < objc; ++tmpc) { + tmpv[tmpc] = objv[tmpc]; + Tcl_IncrRefCount(tmpv[tmpc]); + } + tmpv[tmpc] = Tcl_NewIntObj(dispidMember); + Tcl_IncrRefCount(tmpv[tmpc]); + ++tmpc; for (n = 0; SUCCEEDED(hr) && n < dpPtr->cArgs; ++n) { - hr = OleVariantObj(this->interp, &dpPtr->rgvarg[dpPtr->cArgs - n - 1], &objv[objc]); + hr = OleVariantObj(this->interp, &dpPtr->rgvarg[dpPtr->cArgs - n - 1], &tmpv[tmpc]); if (SUCCEEDED(hr)) { - Tcl_IncrRefCount(objv[objc]); + Tcl_IncrRefCount(tmpv[tmpc]); } - ++objc; + ++tmpc; } if (SUCCEEDED(hr)) { - hr = EvalObjv(this->interp, objc, objv, eiPtr); + hr = EvalObjv(this->interp, tmpc, tmpv, eiPtr); } - for (n = 0; n < objc; ++n) { - Tcl_DecrRefCount(objv[n]); + for (n = 0; n < tmpc; ++n) { + Tcl_DecrRefCount(tmpv[n]); } + ckfree((char *)tmpv); return hr; } diff --git a/src/invoke.c b/src/invoke.c index 1a9ec01..e2eca1b 100644 --- a/src/invoke.c +++ b/src/invoke.c @@ -129,8 +129,8 @@ OleVariantObj(Tcl_Interp *interp, const VARIANT *vPtr, Tcl_Obj **resultPtrPtr) break; case VT_CY: case VT_DECIMAL: case VT_DATE: case VT_VARIANT: - /* *resultPtrPtr = Ole_NewVariantObj(vPtr);*/ - /* break; */ + *resultPtrPtr = Ole_NewVariantObj(vPtr); + break; default: { VARIANT vv; VariantInit(&vv); @@ -327,15 +327,21 @@ OleObjectInvoke(ClientData clientData, Tcl_Interp *interp, } OleDispParamsFree(dp); if (SUCCEEDED(hr)) { - Tcl_Obj *resultObj = Ole_NewVariantObj(v); + Tcl_Obj *resultObj = NULL; /* Ole_NewVariantObj(&v); */ hr = OleVariantObj(interp, &v, &resultObj); if (SUCCEEDED(hr)) { Tcl_SetObjResult(interp, resultObj); } } + if (ei.bstrDescription != NULL) SysFreeString(ei.bstrDescription); + if (ei.bstrSource != NULL) SysFreeString(ei.bstrSource); + if (ei.bstrHelpFile != NULL) SysFreeString(ei.bstrHelpFile); + VariantClear(&v); } if (FAILED(hr)) { + /* if hr == DISP_E_EXCEPTION */ + Tcl_SetObjResult(interp, Ole_Win32ErrorObj(interp, "invoke", hr)); return TCL_ERROR; } diff --git a/src/tclole.c b/src/tclole.c index 74f4300..b8d8013 100644 --- a/src/tclole.c +++ b/src/tclole.c @@ -292,6 +292,7 @@ Ole_Init(Tcl_Interp *interp) 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_CreateObjCommand(interp, "ole::type", OleTypeCmd, (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 c117d39..5ad7d79 100644 --- a/src/tcloleInt.h +++ b/src/tcloleInt.h @@ -112,8 +112,10 @@ int Ole_SetObjResult(Tcl_Interp *interp, const char *prefix, DWORD errorCode); /* varobj.c */ -Tcl_Obj * Ole_NewVariantObj(const VARIANT v); -void Ole_SetVariantObj(Tcl_Obj *objPtr, const VARIANT v); +Tcl_Obj * Ole_NewVariantObj(const VARIANT *varPtr); +void Ole_SetVariantObj(Tcl_Obj *objPtr, const VARIANT *varPtr); +int OleTypeCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); #ifdef __cplusplus diff --git a/src/varobj.c b/src/varobj.c index 82dba41..2f167d1 100644 --- a/src/varobj.c +++ b/src/varobj.c @@ -113,17 +113,17 @@ SetVariantFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr) } Tcl_Obj * -Ole_NewVariantObj(const VARIANT v) +Ole_NewVariantObj(const VARIANT *varPtr) { Tcl_Obj *objPtr = Tcl_NewObj(); - Ole_SetVariantObj(objPtr, v); + Ole_SetVariantObj(objPtr, varPtr); return objPtr; } void -Ole_SetVariantObj(Tcl_Obj *objPtr, const VARIANT v) +Ole_SetVariantObj(Tcl_Obj *objPtr, const VARIANT *varPtr) { - VARIANT *varPtr; + VARIANT *newPtr; if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Ole_SetVariantObj"); @@ -132,13 +132,53 @@ Ole_SetVariantObj(Tcl_Obj *objPtr, const VARIANT v) if (objPtr->typePtr && objPtr->typePtr->freeIntRepProc != NULL) { objPtr->typePtr->freeIntRepProc(objPtr); } - varPtr = (VARIANT *)ckalloc(sizeof(VARIANT)); - VariantInit(varPtr); - VariantCopy(varPtr, GET_VARIANTREP(objPtr)); - SET_VARIANTREP(objPtr, varPtr); + newPtr = (VARIANT *)ckalloc(sizeof(VARIANT)); + VariantInit(newPtr); + VariantCopy(newPtr, (VARIANT *)varPtr); + SET_VARIANTREP(objPtr, newPtr); objPtr->typePtr = &tclVariantType; } +int +OleVariantCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +{ + int n, eltc = 0; + Tcl_Obj **eltv = NULL; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "type value"); + return TCL_ERROR; + } + + if (Tcl_ListObjGetElements(interp, objv[1], &eltc, &eltv) != TCL_OK) { + return TCL_ERROR; + } + + for (n = 0; n < eltc; ++n) { + const char *s = Tcl_GetString(eltv[n]); + + } + + return TCL_ERROR; +} + +int +OleTypeCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]) +{ + const char *name = "string"; + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "value"); + return TCL_ERROR; + } + if (objv[1]->typePtr) { + name = objv[1]->typePtr->name; + } + Tcl_SetObjResult(interp, Tcl_NewStringObj(name, -1)); + return TCL_OK; +} + /* * Local variables: * indent-tabs-mode: t diff --git a/win/nmakehlp.c b/win/nmakehlp.c index ef6e7e3..35b35e5 100644 --- a/win/nmakehlp.c +++ b/win/nmakehlp.c @@ -21,9 +21,15 @@ #pragma comment (lib, "kernel32.lib") #include #include + +/* + * This library is required for x64 builds with _some_ versions of MSVC + */ #if defined(_M_IA64) || defined(_M_AMD64) +#if _MSC_VER >= 1400 && _MSC_VER < 1500 #pragma comment(lib, "bufferoverflowU") #endif +#endif /* ISO hack for dumb VC++ */ #ifdef _MSC_VER @@ -299,7 +305,9 @@ CheckForCompilerFeature( return !(strstr(Out.buffer, "D4002") != NULL || strstr(Err.buffer, "D4002") != NULL || strstr(Out.buffer, "D9002") != NULL - || strstr(Err.buffer, "D9002") != NULL); + || strstr(Err.buffer, "D9002") != NULL + || strstr(Out.buffer, "D2021") != NULL + || strstr(Err.buffer, "D2021") != NULL); } int diff --git a/win/rules.vc b/win/rules.vc index ce63ff2..0da711b 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -192,10 +192,10 @@ VCVER=0 !if ![echo VCVERSION=_MSC_VER > vercl.x] \ && ![cl -nologo -TC -P vercl.x $(ERRNULL)] !include vercl.i -!if $(VCVERSION) >= 1400 +!if $(VCVERSION) >= 1500 +VCVER=9 +!elseif $(VCVERSION) >= 1400 VCVER=8 -_VC_MANIFEST_EMBED_EXE=if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;1 -_VC_MANIFEST_EMBED_DLL=if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;2 !elseif $(VCVERSION) >= 1300 VCVER=7 !elseif $(VCVERSION) >= 1200 @@ -203,6 +203,12 @@ VCVER=6 !endif !endif +# Since MSVC8 we must deal with manifest resources. +!if $(VCVERSION) >= 1400 +_VC_MANIFEST_EMBED_EXE=if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;1 +_VC_MANIFEST_EMBED_DLL=if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;2 +!endif + #---------------------------------------------------------- # Decode the options requested. #---------------------------------------------------------- -- 2.23.0