From: Pat Thoyts <patthoyts@users.sourceforge.net>
Date: Thu, 18 Jun 2009 01:52:12 +0000 (+0100)
Subject: Support compilation against Tcl 8.6 and with MSVC 8 and 9.
X-Git-Url: https://privyetmir.co.uk/gitweb.cgi?a=commitdiff_plain;h=e673c4ccbb53a70ebbb4762567d362fa9e294ae7;p=tcom

Support compilation against Tcl 8.6 and with MSVC 8 and 9.

Signed-off-by: Pat Thoyts <patthoyts@users.sourceforge.net>
---

diff --git a/src/ComObject.cpp b/src/ComObject.cpp
index 89e693e..cb6baf9 100644
--- a/src/ComObject.cpp
+++ b/src/ComObject.cpp
@@ -131,7 +131,7 @@ int
 ComObject::eval (TclObject script, TclObject *pResult)
 {
     int completionCode =
-#if TCL_MINOR_VERSION >= 1
+#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION >= 81
         Tcl_EvalObjEx(m_interp, script, TCL_EVAL_DIRECT | TCL_EVAL_GLOBAL);
 #else
         Tcl_GlobalEvalObj(m_interp, script);
@@ -165,7 +165,7 @@ ComObject::setVariable (TclObject name, TclObject value)
 HRESULT
 ComObject::hresultFromErrorCode () const
 {
-#if TCL_MINOR_VERSION >= 1
+#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION >= 81
     Tcl_Obj *pErrorCode =
         Tcl_GetVar2Ex(m_interp, "::errorCode", 0, TCL_LEAVE_ERR_MSG);
 #else
@@ -569,7 +569,7 @@ convertNativeToTclObject (va_list pArg,
     case VT_LPWSTR:
     case VT_BSTR:
         {
-#if TCL_MINOR_VERSION >= 2
+#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION >= 82
             // Uses Unicode function introduced in Tcl 8.2.
             Tcl_UniChar *pUnicode = byRef ?
                 *va_arg(pArg, Tcl_UniChar **) : va_arg(pArg, Tcl_UniChar *);
diff --git a/src/ComObjectFactory.cpp b/src/ComObjectFactory.cpp
index 710f261..0379a00 100644
--- a/src/ComObjectFactory.cpp
+++ b/src/ComObjectFactory.cpp
@@ -79,7 +79,7 @@ int
 ComObjectFactory::eval (TclObject script, TclObject *pResult)
 {
     int completionCode =
-#if TCL_MINOR_VERSION >= 1
+#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION >= 81
         Tcl_EvalObjEx(m_interp, script, TCL_EVAL_DIRECT | TCL_EVAL_GLOBAL);
 #else
         Tcl_GlobalEvalObj(m_interp, script);
diff --git a/src/Extension.cpp b/src/Extension.cpp
index 01c2037..dcc173b 100644
--- a/src/Extension.cpp
+++ b/src/Extension.cpp
@@ -94,9 +94,9 @@ Extension::typeofCmd (
 	return TCL_ERROR;
     }
 
-    Tcl_ObjType *pType = objv[1]->typePtr;
-    char *name = (pType == 0) ? "NULL" : pType->name;
-    Tcl_SetResult(interp, name, TCL_STATIC);
+    const Tcl_ObjType *pType = objv[1]->typePtr;
+    const char *name = (pType == 0) ? "NULL" : pType->name;
+    Tcl_SetObjResult(interp, Tcl_NewStringObj(name, -1));
     return TCL_OK;
 }
 
diff --git a/src/Extension.h b/src/Extension.h
index a354e98..3d1a19a 100644
--- a/src/Extension.h
+++ b/src/Extension.h
@@ -3,7 +3,7 @@
 #define EXTENSION_H
 
 #include <comdef.h>
-#include <tcl.h>
+#include "tclRunTime.h" //<tcl.h>
 #include "tcomApi.h"
 #include "HandleSupport.h"
 
diff --git a/src/HandleSupport.h b/src/HandleSupport.h
index d3a8d2d..3bfa99c 100644
--- a/src/HandleSupport.h
+++ b/src/HandleSupport.h
@@ -2,7 +2,7 @@
 #ifndef HANDLESUPPORT_H
 #define HANDLESUPPORT_H
 
-#include <tcl.h>
+#include "tclRunTime.h" //<tcl.h>
 #include <string>
 #include "tcomApi.h"
 #include "Singleton.h"
diff --git a/src/HashTable.h b/src/HashTable.h
index 25f6949..1dc144d 100644
--- a/src/HashTable.h
+++ b/src/HashTable.h
@@ -2,7 +2,7 @@
 #ifndef HASHTABLE_H
 #define HASHTABLE_H
 
-#include <tcl.h>
+#include "tclRunTime.h" //<tcl.h>
 
 // Function object that invokes delete on its argument
 
diff --git a/src/Singleton.h b/src/Singleton.h
index 078d93d..2608a38 100644
--- a/src/Singleton.h
+++ b/src/Singleton.h
@@ -2,7 +2,7 @@
 #ifndef SINGLETON_H
 #define SINGLETON_H
 
-#include <tcl.h>
+#include "tclRunTime.h" //<tcl.h>
 #include "mutex.h"
 
 // This template class provides code to construct and destroy a singleton.
diff --git a/src/TclInterp.h b/src/TclInterp.h
index 350695c..b36abe1 100644
--- a/src/TclInterp.h
+++ b/src/TclInterp.h
@@ -3,7 +3,9 @@
 #define TCLINTERP_H
 
 #include <string>
-#include <tcl.h>
+#include "tclRunTime.h" //<tcl.h>
+
+
 
 class TclObject;
 
diff --git a/src/TclObject.cpp b/src/TclObject.cpp
index 2a924b6..3ef5112 100644
--- a/src/TclObject.cpp
+++ b/src/TclObject.cpp
@@ -201,7 +201,7 @@ convertFromSafeArray (
 
         long length = upperBound - lowerBound + 1;
         pResult =
-#if TCL_MINOR_VERSION >= 1
+#if TCL_MAJOR_VERSION * 10 + TCL_MINOR_VERSION >= 81
             // Convert array of bytes to Tcl byte array.
             Tcl_NewByteArrayObj(pData, length);
 #else
@@ -437,9 +437,10 @@ TclObject::TclObject (VARIANT *pSrc, const Type &type, Tcl_Interp *interp)
 TclObject::TclObject (const _bstr_t &src)
 {
     if (src.length() > 0) {
-#if TCL_MINOR_VERSION >= 2
+#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION > 81
         // Uses Unicode functions introduced in Tcl 8.2.
-        m_pObj = Tcl_NewUnicodeObj(src, -1);
+        const wchar_t *wsz = src;
+        m_pObj = Tcl_NewUnicodeObj((const Tcl_UniChar *)wsz, -1);
 #else
         m_pObj = Tcl_NewStringObj(src, -1);
 #endif
@@ -545,7 +546,7 @@ TclObject::getSafeArray (const Type &elementType, Tcl_Interp *interp) const
 
             case VT_I2:
             case VT_UI2:
-                static_cast<short *>(pData)[i] = value.getLong();
+                static_cast<short *>(pData)[i] = static_cast<short>(value.getLong());
                 break;
 
             case VT_R4:
diff --git a/src/TclObject.h b/src/TclObject.h
index 35c3cb2..afa6129 100644
--- a/src/TclObject.h
+++ b/src/TclObject.h
@@ -6,7 +6,7 @@
 #include "TypeInfo.h"
 #include "NativeValue.h"
 #endif
-#include <tcl.h>
+#include "tclRunTime.h" //<tcl.h>
 #include <string>
 #include "tcomApi.h"
 
@@ -34,7 +34,7 @@ public:
     static Tcl_ObjType *listType ()
     { return ms_pListType; }
 
-#if TCL_MINOR_VERSION >= 1
+#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION >= 81
 private:
     static Tcl_ObjType *ms_pByteArrayType;
 
@@ -75,7 +75,7 @@ public:
     const char *c_str () const
     { return Tcl_GetStringFromObj(const_cast<Tcl_Obj *>(m_pObj), 0); }
 
-#if TCL_MINOR_VERSION >= 2
+#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION >= 82
     // Construct Unicode string value.
     TclObject(const wchar_t *src, int len = -1);
 
diff --git a/src/foreachCmd.cpp b/src/foreachCmd.cpp
index f6e5758..b730638 100644
--- a/src/foreachCmd.cpp
+++ b/src/foreachCmd.cpp
@@ -156,7 +156,7 @@ Extension::foreachCmd (
 
         // Execute the script body.
         completionCode =
-#if TCL_MINOR_VERSION >= 1
+#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION >= 81
             Tcl_EvalObjEx(interp, pBody, 0);
 #else
             Tcl_EvalObj(interp, pBody);
@@ -169,7 +169,7 @@ Extension::foreachCmd (
             break;
         } else if (completionCode == TCL_ERROR) {
 	    std::ostringstream oss;
-            oss << "\n    (\"foreach\" body line %d)" << interp->errorLine;
+            oss << "\n    (\"foreach\" body line %d)" << Tcl_GetErrorLine(interp);
             Tcl_AddObjErrorInfo(
                 interp, const_cast<char *>(oss.str().c_str()), -1);
             break;
diff --git a/src/importCmd.cpp b/src/importCmd.cpp
index b3d5c8b..b178499 100644
--- a/src/importCmd.cpp
+++ b/src/importCmd.cpp
@@ -173,7 +173,7 @@ Extension::interfaceCmd (
         s_pCurrentInterface = pInterface;
 
         int completionCode =
-#if TCL_MINOR_VERSION >= 1
+#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION >= 81
             Tcl_EvalObjEx(interp, objv[3], TCL_EVAL_GLOBAL);
 #else
             Tcl_GlobalEvalObj(interp, objv[3]);
@@ -484,7 +484,7 @@ Extension::importCmd (
 
         script << '}' << std::endl;     // end of namespace
 
-#if TCL_MINOR_VERSION >= 1
+#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION >= 81
         Tcl_EvalEx(
             interp,
             const_cast<char *>(script.str().c_str()),
diff --git a/src/main.cpp b/src/main.cpp
index eff5738..4c0a27e 100644
--- a/src/main.cpp
+++ b/src/main.cpp
@@ -6,6 +6,8 @@
 #include "version.h"
 #include "tclRunTime.h"
 
+#pragma comment(lib, "rpcrt4")
+
 /*
  *	This procedure performs application-specific initialization.
  *	Most applications, especially those that incorporate additional
@@ -21,12 +23,10 @@
 extern "C" DLLEXPORT int
 Tcom_Init (Tcl_Interp *interp)
 {
-#ifdef USE_TCL_STUBS
     // Stubs were introduced in Tcl 8.1.
     if (Tcl_InitStubs(interp, "8.1", 0) == NULL) {
         return TCL_ERROR;
     }
-#endif
 
     // Get pointers to Tcl's built-in internal representation types.
     TclTypes::initialize();
diff --git a/src/refCmd.cpp b/src/refCmd.cpp
index a21daef..9a96457 100644
--- a/src/refCmd.cpp
+++ b/src/refCmd.cpp
@@ -43,7 +43,7 @@ getErrorInfo (Reference *pReference, IErrorInfo **ppErrorInfo)
 static Tcl_Obj *
 formatMessage (HRESULT hresult)
 {
-#if TCL_MINOR_VERSION >= 2
+#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION >= 82
     // Uses Unicode functions introduced in Tcl 8.2.
     wchar_t *pMessage;
     DWORD nLen = FormatMessageW(
@@ -77,9 +77,9 @@ formatMessage (HRESULT hresult)
         pMessage[nLen] = '\0';
 
         
-#if TCL_MINOR_VERSION >= 2
+#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION >= 82
         // Uses Unicode functions introduced in Tcl 8.2.
-        pDescription = Tcl_NewUnicodeObj(pMessage, nLen);
+        pDescription = Tcl_NewUnicodeObj((const Tcl_UniChar *)pMessage, nLen);
 #else
         pDescription = Tcl_NewStringObj(pMessage, nLen);
 #endif
@@ -523,8 +523,8 @@ getObjectCmd (
 	return TCL_ERROR;
     }
 
-#if TCL_MINOR_VERSION >= 2
-    const wchar_t *monikerName = Tcl_GetUnicode(objv[2]);
+#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION >= 82
+    const wchar_t *monikerName = (const wchar_t *)Tcl_GetUnicode(objv[2]);
 #else
     _bstr_t monikerName(Tcl_GetStringFromObj(objv[2], 0));
 #endif
diff --git a/src/tclRunTime.h b/src/tclRunTime.h
index 3bac0cb..2e40926 100644
--- a/src/tclRunTime.h
+++ b/src/tclRunTime.h
@@ -4,6 +4,14 @@
 
 #include <tcl.h>
 
+// Tcl API compatability macros
+
+// Tcl 8.6 introduced Tcl_GetErrorLine and removed interp->errorLine
+#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 86
+#define Tcl_GetErrorLine(interp) (interp)->errorLine
+#define CONST86
+#endif
+
 // Link the Tcl run-time library.
 #ifdef USE_TCL_STUBS
 #pragma comment(lib, \
diff --git a/src/variantCmd.cpp b/src/variantCmd.cpp
index cbad50e..0a5e3e9 100644
--- a/src/variantCmd.cpp
+++ b/src/variantCmd.cpp
@@ -39,7 +39,7 @@ variantSetFromAny (Tcl_Interp *interp, Tcl_Obj *pObj)
 {
     const char *stringRep = Tcl_GetStringFromObj(pObj, 0);
 
-    Tcl_ObjType *pOldType = pObj->typePtr;
+    const Tcl_ObjType *pOldType = pObj->typePtr;
     if (pOldType != NULL && pOldType->freeIntRepProc != NULL) {
 	pOldType->freeIntRepProc(pObj);
     }