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.

diff --git a/library/http.tcl b/library/http.tcl
index 6b89d951dd2fe1505503833b5d742dd1ed665635..545b93da2a7934353a3598d9f5d0d5e679756d49 100644 (file)
--- 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 a7f9ed08c00253fae21c390aa54cbf9f583a9fba..b3c144ca67f2079fcf52b4c58d1d5da2cd7ce432 100644 (file)
--- 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 1a9ec0179772617ef583f10022c70d2490c7d92f..e2eca1be93f44d3c6654136c16d05d1fd596deb8 100644 (file)
--- 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 74f4300d9cbd667d72247af7eb1c293f31a1e229..b8d8013856d2ca31748f369bee9ae5c40ea07278 100644 (file)
--- 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 c117d396b011d545fb77b50e995eaa7891eeb263..5ad7d79ec398b58bb0c702ffd0b4dee701f4726a 100644 (file)
--- 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 82dba4199d4e22f5996a91aaaf81feb7329139df..2f167d185366f1062ddc097c3b4452eb81c7d562 100644 (file)
--- 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 ef6e7e3b1f997721bb936f7beaab7b0854d4fc9b..35b35e505fbf6d3d667ca54fa66a9bf7f047ca52 100644 (file)
--- a/win/nmakehlp.c
+++ b/win/nmakehlp.c
@@ -21,9 +21,15 @@
 #pragma comment (lib, "kernel32.lib")
 #include <stdio.h>
 #include <math.h>
+
+/*
+ * 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);
 }
 \f
 int

diff --git a/win/rules.vc b/win/rules.vc
index ce63ff227b43bc914ca22cbfafbf35c40076f860..0da711b3aee118015e7cfa6e4e19caa479255a3b 100644 (file)
--- 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.
 #----------------------------------------------------------