From 1d71db3ab327d81aa5688ce7776ef296fa6a8f46 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Fri, 4 Jan 2013 13:42:27 +0000
Subject: Tk_InitStubs("8.6",1) would succeed in an "8.60" interp. Fixed. No
 longer use Tcl_SetResult() for setting the error message, but
 Tcl_ResetResult/Tcl_AppendResult, as all other stub libraries do. This will
 allow us to remove Tcl_SetResult() in Tcl 9.0, eventually

---
 generic/tkStubLib.c | 103 ++++++++++++++++++++++++++--------------------------
 1 file changed, 51 insertions(+), 52 deletions(-)

diff --git a/generic/tkStubLib.c b/generic/tkStubLib.c
index b4063b5..fe30f26 100644
--- a/generic/tkStubLib.c
+++ b/generic/tkStubLib.c
@@ -1,28 +1,16 @@
 /*
  * tkStubLib.c --
  *
- *	Stub object that will be statically linked into extensions that wish
+ *	Stub object that will be statically linked into extensions that want
  *	to access Tk.
  *
- * Copyright (c) 1998 Paul Duffin.
  * Copyright (c) 1998-1999 by Scriptics Corporation.
+ * Copyright (c) 1998 Paul Duffin.
  *
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  */
 
-/*
- * We need to ensure that we use the stub macros so that this file contains no
- * references to any of the stub functions. This will make it possible to
- * build an extension that references Tk_InitStubs but doesn't end up
- * including the rest of the stub functions.
- */
-
-#undef USE_TCL_STUBS
-#define USE_TCL_STUBS
-
-#define USE_TK_STUBS
-
 #include "tkInt.h"
 
 #ifdef __WIN32__
@@ -58,8 +46,7 @@ const TkIntXlibStubs *tkIntXlibStubsPtr = NULL;
  */
 
 static int
-isDigit(
-    const int c)
+isDigit(const int c)
 {
     return (c >= '0' && c <= '9');
 }
@@ -81,61 +68,73 @@ isDigit(
  *
  *----------------------------------------------------------------------
  */
-
+#undef Tk_InitStubs
 MODULE_SCOPE const char *
 Tk_InitStubs(
     Tcl_Interp *interp,
     const char *version,
     int exact)
 {
-    ClientData pkgClientData = NULL;
-    const char *actualVersion = Tcl_PkgRequireEx(interp, "Tk", version, 0,
-	    &pkgClientData);
-    const TkStubs *stubsPtr = pkgClientData;
-
-    if (!actualVersion) {
+    const char *packageName = "Tk";
+    const char *errMsg = NULL;
+    ClientData clientData = NULL;
+    const char *actualVersion = tclStubsPtr->tcl_PkgRequireEx(interp,
+	    packageName, version, 0, &clientData);
+    const TkStubs *stubsPtr = clientData;
+
+    if (actualVersion == NULL) {
 	return NULL;
     }
+
     if (exact) {
-        const char *p = version;
-        int count = 0;
+	const char *p = version;
+	int count = 0;
 
-        while (*p) {
-            count += !isDigit(*p++);
-        }
-        if (count == 1) {
+	while (*p) {
+	    count += !isDigit(*p++);
+	}
+	if (count == 1) {
 	    const char *q = actualVersion;
 
 	    p = version;
 	    while (*p && (*p == *q)) {
 		p++; q++;
 	    }
-            if (*p) {
+	    if (*p || isDigit(*q)) {
 		/* Construct error message */
-		Tcl_PkgRequireEx(interp, "Tk", version, 1, NULL);
-                return NULL;
-            }
-        } else {
-            actualVersion = Tcl_PkgRequireEx(interp, "Tk", version, 1, NULL);
-            if (actualVersion == NULL) {
-                return NULL;
-            }
-        }
+		tclStubsPtr->tcl_PkgRequireEx(interp, packageName, version, 1, NULL);
+		return NULL;
+	    }
+	} else {
+	    actualVersion = tclStubsPtr->tcl_PkgRequireEx(interp, packageName,
+		    version, 1, NULL);
+	    if (actualVersion == NULL) {
+		return NULL;
+	    }
+	}
     }
-
-    if (!stubsPtr) {
-	Tcl_SetObjResult(interp, Tcl_NewStringObj(
-		"this implementation of Tk does not support stubs", -1));
-	return NULL;
+    if (stubsPtr == NULL) {
+	errMsg = "missing stub table pointer";
+    } else {
+	tkStubsPtr = stubsPtr;
+	if (stubsPtr->hooks) {
+	    tkPlatStubsPtr = stubsPtr->hooks->tkPlatStubs;
+	    tkIntStubsPtr = stubsPtr->hooks->tkIntStubs;
+	    tkIntPlatStubsPtr = stubsPtr->hooks->tkIntPlatStubs;
+	    tkIntXlibStubsPtr = stubsPtr->hooks->tkIntXlibStubs;
+	} else {
+	    tkPlatStubsPtr = NULL;
+	    tkIntStubsPtr = NULL;
+	    tkIntPlatStubsPtr = NULL;
+	    tkIntXlibStubsPtr = NULL;
+	}
+	return actualVersion;
     }
-
-    tkPlatStubsPtr = stubsPtr->hooks->tkPlatStubs;
-    tkIntStubsPtr = stubsPtr->hooks->tkIntStubs;
-    tkIntPlatStubsPtr = stubsPtr->hooks->tkIntPlatStubs;
-    tkIntXlibStubsPtr = stubsPtr->hooks->tkIntXlibStubs;
-    tkStubsPtr = stubsPtr;
-
-    return actualVersion;
+    tclStubsPtr->tcl_ResetResult(interp);
+    tclStubsPtr->tcl_AppendResult(interp, "Error loading ", packageName,
+	    " (requested version ", version, ", actual version ",
+	    actualVersion, "): ", errMsg, NULL);
+    return NULL;
 }
 
 /*
-- 
cgit v0.12