Tcl Source Code

Artifact 52a614b9283c05ee9e50db4c6a9f2d192f58bcf8:

Attachment "initstubs.patch" to ticket [1578344fff] added by dgp 2007-09-12 20:49:03.

---

Index: generic/tcl.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tcl.h,v
retrieving revision 1.234
diff -u -r1.234 tcl.h
--- generic/tcl.h	31 Jul 2007 17:03:35 -0000	1.234
+++ generic/tcl.h	12 Sep 2007 13:31:51 -0000
@@ -2216,7 +2216,7 @@
  */
 
 #define Tcl_InitStubs(interp, version, exact) \
-    Tcl_PkgRequire(interp, "Tcl", version, exact)
+    Tcl_PkgInitStubsCheck(interp, version, exact)
 
 #endif
 
@@ -2232,6 +2232,9 @@
 EXTERN void Tcl_Main _ANSI_ARGS_((int argc, char **argv,
 	Tcl_AppInitProc *appInitProc));
 
+EXTERN CONST char *Tcl_PkgInitStubsCheck _ANSI_ARGS_((Tcl_Interp *interp,
+			    CONST char *version, int exact));
+
 /*
  * Include the public function declarations that are accessible via the stubs
  * table.
Index: generic/tclPkg.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclPkg.c,v
retrieving revision 1.29
diff -u -r1.29 tclPkg.c
--- generic/tclPkg.c	11 Sep 2007 17:46:07 -0000	1.29
+++ generic/tclPkg.c	12 Sep 2007 13:31:51 -0000
@@ -1825,6 +1825,50 @@
 }
 
 /*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_PkgInitStubsCheck --
+ *
+ *	This is a replacement routine for Tcl_InitStubs() that is called
+ *	from code where -DUSE_TCL_STUBS has not been enabled.
+ *
+ * Results:
+ *	Returns the version of a conforming stubs table, or NULL, if
+ *	the table version doesn't satisfy the requested requirements,
+ *	according to historical practice.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+CONST char *
+Tcl_PkgInitStubsCheck(
+    Tcl_Interp *interp,
+    CONST char * version,
+    int exact)
+{
+    CONST char *actualVersion = Tcl_PkgPresent(interp, "Tcl", version, 0);
+
+    if (exact && actualVersion) {
+	CONST char *p = version;
+	int count = 0;
+
+	while (*p) {
+	    count += !isdigit(*p++);
+	}
+	if (count == 1) {
+	    if (0 != strncmp(version, actualVersion, strlen(version))) {
+		return NULL;
+	    }
+	} else {
+	    return Tcl_PkgPresent(interp, "Tcl", version, 1);
+	}
+    }
+    return actualVersion;
+}
+/*
  * Local Variables:
  * mode: c
  * c-basic-offset: 4
Index: generic/tclStubLib.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclStubLib.c,v
retrieving revision 1.15
diff -u -r1.15 tclStubLib.c
--- generic/tclStubLib.c	16 May 2007 18:28:40 -0000	1.15
+++ generic/tclStubLib.c	12 Sep 2007 13:31:51 -0000
@@ -95,10 +95,28 @@
 	return NULL;
     }
 
-    actualVersion = Tcl_PkgRequireEx(interp, "Tcl", version, exact, &pkgData);
+    actualVersion = Tcl_PkgRequireEx(interp, "Tcl", version, 0, &pkgData);
     if (actualVersion == NULL) {
 	return NULL;
     }
+    if (exact) {
+	CONST char *p = version;
+	int count = 0;
+
+	while (*p) {
+	    count += !isdigit(*p++);
+	}
+	if (count == 1) {
+	    if (0 != strncmp(version, actualVersion, strlen(version))) {
+		return NULL;
+	    }
+	} else {
+	    actualVersion = Tcl_PkgRequireEx(interp, "Tcl", version, 1, NULL);
+	    if (actualVersion == NULL) {
+		return NULL;
+	    }
+	}
+    }
     tclStubsPtr = (TclStubs*)pkgData;
 
     if (tclStubsPtr->hooks) {