Attachment "1578344-3.patch" to
ticket [1578344fff]
added by
dgp
2007-05-29 20:34:14.
Index: generic/tcl.decls
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tcl.decls,v
retrieving revision 1.126
diff -u -r1.126 tcl.decls
--- generic/tcl.decls 16 May 2007 21:18:22 -0000 1.126
+++ generic/tcl.decls 29 May 2007 13:30:53 -0000
@@ -2095,6 +2095,12 @@
void Tcl_AppendPrintfToObj(Tcl_Obj *objPtr, CONST char *format, ...)
}
+# TIP#268: Extended version numbers and requirements
+declare 580 generic {
+ CONST char * Tcl_PkgRequirePrefixMatch(Tcl_Interp *interp, CONST char *name,
+ CONST char *version, ClientData *clientDataPtr)
+}
+
##############################################################################
# Define the platform specific public Tcl interface. These functions are
Index: generic/tcl.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tcl.h,v
retrieving revision 1.231
diff -u -r1.231 tcl.h
--- generic/tcl.h 18 May 2007 18:39:30 -0000 1.231
+++ generic/tcl.h 29 May 2007 13:30:54 -0000
@@ -2236,8 +2236,10 @@
* When not using stubs, make it a macro.
*/
-#define Tcl_InitStubs(interp, version, exact) \
- Tcl_PkgRequire(interp, "Tcl", version, exact)
+#define Tcl_InitStubs(interp, version, prefixMatching) \
+ (prefixMatching) ? \
+ Tcl_PkgRequirePrefixMatch(interp, "Tcl", version, NULL) : \
+ Tcl_PkgRequire(interp, "Tcl", version, 0))
#endif
Index: generic/tclBasic.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclBasic.c,v
retrieving revision 1.244
diff -u -r1.244 tclBasic.c
--- generic/tclBasic.c 20 Apr 2007 05:51:08 -0000 1.244
+++ generic/tclBasic.c 29 May 2007 13:30:54 -0000
@@ -722,11 +722,6 @@
Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, (ClientData) &tclStubs);
-#ifdef Tcl_InitStubs
-#undef Tcl_InitStubs
-#endif
- Tcl_InitStubs(interp, TCL_VERSION, 1);
-
if (TclTommath_Init(interp) != TCL_OK) {
Tcl_Panic(Tcl_GetString(Tcl_GetObjResult(interp)));
}
Index: generic/tclDecls.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclDecls.h,v
retrieving revision 1.128
diff -u -r1.128 tclDecls.h
--- generic/tclDecls.h 23 Feb 2007 23:02:53 -0000 1.128
+++ generic/tclDecls.h 29 May 2007 13:30:55 -0000
@@ -3455,6 +3455,13 @@
EXTERN void Tcl_AppendPrintfToObj (Tcl_Obj * objPtr,
CONST char * format, ...);
#endif
+#ifndef Tcl_PkgRequirePrefixMatch_TCL_DECLARED
+#define Tcl_PkgRequirePrefixMatch_TCL_DECLARED
+/* 580 */
+EXTERN CONST char * Tcl_PkgRequirePrefixMatch (Tcl_Interp * interp,
+ CONST char * name, CONST char * version,
+ ClientData * clientDataPtr);
+#endif
typedef struct TclStubHooks {
struct TclPlatStubs *tclPlatStubs;
@@ -4076,6 +4083,7 @@
int (*tcl_AppendFormatToObj) (Tcl_Interp * interp, Tcl_Obj * objPtr, CONST char * format, int objc, Tcl_Obj * CONST objv[]); /* 577 */
Tcl_Obj * (*tcl_ObjPrintf) (CONST char * format, ...); /* 578 */
void (*tcl_AppendPrintfToObj) (Tcl_Obj * objPtr, CONST char * format, ...); /* 579 */
+ CONST char * (*tcl_PkgRequirePrefixMatch) (Tcl_Interp * interp, CONST char * name, CONST char * version, ClientData * clientDataPtr); /* 580 */
} TclStubs;
#ifdef __cplusplus
@@ -6436,6 +6444,10 @@
#define Tcl_AppendPrintfToObj \
(tclStubsPtr->tcl_AppendPrintfToObj) /* 579 */
#endif
+#ifndef Tcl_PkgRequirePrefixMatch
+#define Tcl_PkgRequirePrefixMatch \
+ (tclStubsPtr->tcl_PkgRequirePrefixMatch) /* 580 */
+#endif
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
Index: generic/tclPkg.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclPkg.c,v
retrieving revision 1.27
diff -u -r1.27 tclPkg.c
--- generic/tclPkg.c 20 Apr 2007 06:10:58 -0000 1.27
+++ generic/tclPkg.c 29 May 2007 13:30:56 -0000
@@ -64,16 +64,17 @@
static int CheckAllRequirements(Tcl_Interp *interp, int reqc,
Tcl_Obj *CONST reqv[]);
static int RequirementSatisfied(char *havei, CONST char *req);
-static int AllRequirementsSatisfied(char *havei, int reqc,
+static int SomeRequirementSatisfied(char *havei, int reqc,
Tcl_Obj *CONST reqv[]);
static void AddRequirementsToResult(Tcl_Interp *interp, int reqc,
Tcl_Obj *CONST reqv[]);
static void AddRequirementsToDString(Tcl_DString *dstring,
int reqc, Tcl_Obj *CONST reqv[]);
static Package * FindPackage(Tcl_Interp *interp, CONST char *name);
-static Tcl_Obj * ExactRequirement(CONST char *version);
-static void VersionCleanupProc(ClientData clientData,
- Tcl_Interp *interp);
+static Tcl_Obj * PrefixMatchRequirement(CONST char *version);
+static const char * PkgRequireCore(Tcl_Interp *interp, CONST char *name,
+ int reqc, Tcl_Obj *CONST reqv[],
+ ClientData *clientDataPtr);
/*
* Helper macros.
@@ -218,7 +219,7 @@
* call fails for any reason. */
{
Tcl_Obj *ov;
- int res;
+ const char *result = NULL;
/*
* If an attempt is being made to load this into a standalone executable
@@ -294,49 +295,44 @@
/* Translate between old and new API, and defer to the new function. */
if (version == NULL) {
- res = Tcl_PkgRequireProc(interp, name, 0, NULL, clientDataPtr);
+ result = PkgRequireCore(interp, name, 0, NULL, clientDataPtr);
} else {
+ if (exact && TCL_OK
+ != CheckVersionAndConvert(interp, version, NULL, NULL)) {
+ return NULL;
+ }
+ ov = Tcl_NewStringObj(version, -1);
if (exact) {
- ov = ExactRequirement(version);
- } else {
- ov = Tcl_NewStringObj(version, -1);
+ Tcl_AppendStringsToObj(ov, "-", version, NULL);
}
-
Tcl_IncrRefCount(ov);
- res = Tcl_PkgRequireProc(interp, name, 1, &ov, clientDataPtr);
+ result = PkgRequireCore(interp, name, 1, &ov, clientDataPtr);
TclDecrRefCount(ov);
}
- if (res != TCL_OK) {
- return NULL;
- }
-
- /*
- * This function returns the version string explictly, and leaves the
- * interpreter result empty. However "Tcl_PkgRequireProc" above returned
- * the version through the interpreter result. Simply resetting the result
- * now potentially deletes the string (obj), and the pointer to its string
- * rep we have, as our result, may be dangling due to this. Our solution
- * is to remember the object in interp associated data, with a proper
- * reference count, and then reset the result. Now pointers will not
- * dangle. It will be a leak however if nothing is done. So the next time
- * we come through here we delete the object remembered by this call, as
- * we can then be sure that there is no pointer to its string around
- * anymore. Beyond that we have a deletion function which cleans up the
- * last remembered object which was not cleaned up directly, here.
- */
+ return result;
+}
- ov = (Tcl_Obj *) Tcl_GetAssocData(interp, "tcl/Tcl_PkgRequireEx", NULL);
- if (ov != NULL) {
- TclDecrRefCount(ov);
- }
+CONST char *
+Tcl_PkgRequirePrefixMatch(
+ Tcl_Interp *interp, /* Interpreter in which package is now
+ * available. */
+ CONST char *name, /* Name of desired package. */
+ CONST char *versionPrefix, /* Prefix to match */
+ ClientData *clientDataPtr) /* Used to return the client data for this
+ * package. If it is NULL then the client data
+ * is not returned. This is unchanged if this
+ * call fails for any reason. */
+{
+ Tcl_Obj *ov;
+ const char *result = NULL;
- ov = Tcl_GetObjResult(interp);
+ /* Translate between old and new API, and defer to the new function. */
+ ov = PrefixMatchRequirement(versionPrefix);
Tcl_IncrRefCount(ov);
- Tcl_SetAssocData(interp, "tcl/Tcl_PkgRequireEx", VersionCleanupProc, ov);
- Tcl_ResetResult(interp);
-
- return TclGetString(ov);
+ result = PkgRequireCore(interp, name, 1, &ov, clientDataPtr);
+ TclDecrRefCount(ov);
+ return result;
}
int
@@ -350,6 +346,27 @@
* available. */
ClientData *clientDataPtr)
{
+ const char *result =
+ PkgRequireCore(interp, name, reqc, reqv, clientDataPtr);
+
+ if (result == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(result, -1));
+ return TCL_OK;
+}
+
+static const char *
+PkgRequireCore(
+ Tcl_Interp *interp, /* Interpreter in which package is now
+ * available. */
+ CONST char *name, /* Name of desired package. */
+ int reqc, /* Requirements constraining the desired
+ * version. */
+ Tcl_Obj *CONST reqv[], /* 0 means to use the latest version
+ * available. */
+ ClientData *clientDataPtr)
+{
Interp *iPtr = (Interp *) interp;
Package *pkgPtr;
PkgAvail *availPtr, *bestPtr, *bestStablePtr;
@@ -384,7 +401,7 @@
"attempt to provide ", name, " ",
(char *) pkgPtr->clientData, " requires ", name, NULL);
AddRequirementsToResult(interp, reqc, reqv);
- return TCL_ERROR;
+ return NULL;
}
/*
@@ -436,7 +453,7 @@
* Check satisfaction of requirements.
*/
- satisfies = AllRequirementsSatisfied(availVersion,reqc,reqv);
+ satisfies = SomeRequirementSatisfied(availVersion,reqc,reqv);
if (!satisfies) {
ckfree(availVersion);
availVersion = NULL;
@@ -562,7 +579,7 @@
pkgPtr->version = NULL;
}
pkgPtr->clientData = NULL;
- return TCL_ERROR;
+ return NULL;
}
break;
@@ -600,7 +617,7 @@
if (code == TCL_ERROR) {
Tcl_AddErrorInfo(interp,
"\n (\"package unknown\" script)");
- return TCL_ERROR;
+ return NULL;
}
Tcl_ResetResult(interp);
}
@@ -609,7 +626,7 @@
if (pkgPtr->version == NULL) {
Tcl_AppendResult(interp, "can't find package ", name, NULL);
AddRequirementsToResult(interp, reqc, reqv);
- return TCL_ERROR;
+ return NULL;
}
/*
@@ -621,7 +638,7 @@
satisfies = 1;
} else {
CheckVersionAndConvert(interp, pkgPtr->version, &pkgVersionI, NULL);
- satisfies = AllRequirementsSatisfied(pkgVersionI, reqc, reqv);
+ satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv);
ckfree(pkgVersionI);
}
@@ -630,14 +647,13 @@
if (clientDataPtr) {
*clientDataPtr = pkgPtr->clientData;
}
- Tcl_SetObjResult(interp, Tcl_NewStringObj(pkgPtr->version, -1));
- return TCL_OK;
+ return pkgPtr->version;
}
Tcl_AppendResult(interp, "version conflict for package \"", name,
"\": have ", pkgPtr->version, ", need", NULL);
AddRequirementsToResult(interp, reqc, reqv);
- return TCL_ERROR;
+ return NULL;
}
/*
@@ -997,7 +1013,8 @@
* Create a new-style requirement for the exact version.
*/
- ov = ExactRequirement(version);
+ ov = Tcl_NewStringObj(version, -1);
+ Tcl_AppendStringsToObj(ov, "-", version, NULL);
version = NULL;
argv3 = TclGetString(objv[3]);
@@ -1134,7 +1151,7 @@
return TCL_ERROR;
}
- satisfies = AllRequirementsSatisfied(argv2i, objc-3, objv+3);
+ satisfies = SomeRequirementSatisfied(argv2i, objc-3, objv+3);
ckfree(argv2i);
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(satisfies));
@@ -1662,7 +1679,15 @@
int i;
for (i = 0; i < reqc; i++) {
- Tcl_AppendResult(interp, " ", TclGetString(reqv[i]), NULL);
+ int length;
+ char *v = Tcl_GetStringFromObj(reqv[i], &length);
+
+ if ((length & 0x1) && (v[length/2] == '-')
+ && (strncmp(v, v+((length+1)/2), length/2) == 0)) {
+ Tcl_AppendResult(interp, " exactly ", v+((length+1)/2), NULL);
+ } else {
+ Tcl_AppendResult(interp, " ", v, NULL);
+ }
}
}
}
@@ -1706,7 +1731,7 @@
/*
*----------------------------------------------------------------------
*
- * AllRequirementSatisfied --
+ * SomeRequirementSatisfied --
*
* This function checks to see whether a version satisfies at least one
* of a set of requirements.
@@ -1723,7 +1748,7 @@
*/
static int
-AllRequirementsSatisfied(
+SomeRequirementSatisfied(
char *availVersionI, /* Candidate version to check against the
* requirements. */
int reqc, /* Requirements constraining the desired
@@ -1845,11 +1870,14 @@
/*
*----------------------------------------------------------------------
*
- * ExactRequirement --
+ * PrefixMatchRequirement --
*
- * This function is the core for the translation of -exact requests. It
- * translates the request of the version into a range of versions. The
- * translation was chosen for backwards compatibility.
+ * Converts a version number prefix into a requirement effecting
+ * prefix matching. Examples:
+ * 8 => 8-9
+ * 8.5 => 8.5-8.6
+ * 8.5.1 => 8.5.1-8.5.2
+ * 8.5a7 => 8.5a7-8.5a8
*
* Results:
* A Tcl_Obj containing the version range as string.
@@ -1861,33 +1889,9 @@
*/
static Tcl_Obj *
-ExactRequirement(
+PrefixMatchRequirement(
CONST char *version)
{
- /*
- * A -exact request for a version X.y is translated into the range
- * X.y-X.(y+1). For example -exact 8.4 means the range "8.4-8.5".
- *
- * This translation was chosen to prevent packages which currently use a
- * 'package require -exact tclversion' from being affected by the core now
- * registering itself as 8.4.x (patchlevel) instead of 8.4 (version).
- * Examples are tbcload, compiler, and ITcl.
- *
- * Translating -exact 8.4 to the range "8.4-8.4" instead would require us
- * and everyone else to rebuild these packages to require -exact 8.4.14,
- * or whatever the exact current patchlevel is. A backward compatibility
- * issue with effects similar to the bugfix made in 8.5 now requiring
- * ifneeded and provided versions to match. Instead we have chosen to
- * interpret exactness to not be exactly equal, but to be exact only
- * within the specified level, and allowing variation in the deeper level.
- * More examples:
- *
- * -exact 8 => "8-9"
- * -exact 8.4 => "8.4-8.5"
- * -exact 8.4.14 => "8.4.14-8.4.15"
- * -exact 8.0a2 => "8.0a2-8.0a3"
- */
-
char *iv, buf[30];
int lc, i;
CONST char **lv;
@@ -1946,36 +1950,6 @@
}
/*
- *----------------------------------------------------------------------
- *
- * VersionCleanupProc --
- *
- * This function is called to delete the last remember package version
- * string for an interpreter when the interpreter is deleted. It gets
- * invoked via the Tcl AssocData mechanism.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Storage for the version object for interp get deleted.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-VersionCleanupProc(
- ClientData clientData, /* Pointer to remembered version string object
- * for interp. */
- Tcl_Interp *interp) /* Interpreter that is being deleted. */
-{
- Tcl_Obj *ov = clientData;
- if (ov != NULL) {
- TclDecrRefCount(ov);
- }
-}
-
-/*
* Local Variables:
* mode: c
* c-basic-offset: 4
Index: generic/tclStubInit.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclStubInit.c,v
retrieving revision 1.140
diff -u -r1.140 tclStubInit.c
--- generic/tclStubInit.c 5 May 2007 23:36:36 -0000 1.140
+++ generic/tclStubInit.c 29 May 2007 13:30:56 -0000
@@ -1085,6 +1085,7 @@
Tcl_AppendFormatToObj, /* 577 */
Tcl_ObjPrintf, /* 578 */
Tcl_AppendPrintfToObj, /* 579 */
+ Tcl_PkgRequirePrefixMatch, /* 580 */
};
/* !END!: Do not edit above this line. */
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 29 May 2007 13:30:56 -0000
@@ -79,7 +79,7 @@
Tcl_InitStubs(
Tcl_Interp *interp,
CONST char *version,
- int exact)
+ int prefixMatching)
{
CONST char *actualVersion = NULL;
ClientData pkgData = NULL;
@@ -94,8 +94,18 @@
if (!tclStubsPtr) {
return NULL;
}
-
- actualVersion = Tcl_PkgRequireEx(interp, "Tcl", version, exact, &pkgData);
+ if (prefixMatching) {
+ if (Tcl_PkgRequireEx(interp, "Tcl", "8.5a7", 0, NULL) != NULL) {
+ actualVersion = Tcl_PkgRequirePrefixMatch(interp,
+ "Tcl", version, &pkgData);
+ } else {
+ Tcl_ResetResult(interp);
+ }
+ }
+ if (actualVersion == NULL) {
+ actualVersion = Tcl_PkgRequireEx(interp,
+ "Tcl", version, prefixMatching, &pkgData);
+ }
if (actualVersion == NULL) {
return NULL;
}
@@ -131,10 +141,6 @@
*----------------------------------------------------------------------
*/
-#ifdef TclTomMathInitializeStubs
-#undef TclTomMathInitializeStubs
-#endif
-
CONST char*
TclTomMathInitializeStubs(
Tcl_Interp* interp, /* Tcl interpreter */
Index: tests/pkg.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/pkg.test,v
retrieving revision 1.26
diff -u -r1.26 pkg.test
--- tests/pkg.test 22 Feb 2007 20:25:40 -0000 1.26
+++ tests/pkg.test 29 May 2007 13:30:57 -0000
@@ -142,7 +142,7 @@
package ifneeded t $i "set x $i"
}
list [catch {package require -exact t 1.3} msg] $msg
-} {1 {can't find package t 1.3-1.4}}
+} {1 {can't find package t exactly 1.3}}
test pkg-2.9 {Tcl_PkgRequire procedure, can't find suitable version} {
package forget t
package unknown {}
@@ -188,7 +188,7 @@
package require -exact t 1.5
package unknown {}
set x
-} {t 1.5-1.6}
+} {t 1.5-1.5}
test pkg-2.14 {Tcl_PkgRequire procedure, "package unknown" support} {
proc pkgUnknown args {
package ifneeded t 1.2 "set x loaded; package provide t 1.2"
@@ -245,7 +245,7 @@
set result [list [catch {package require -exact t 1.5} msg] $msg $x]
package unknown {}
set result
-} {1 {can't find package t 1.5-1.6} {t 1.5-1.6}}
+} {1 {can't find package t exactly 1.5} {t 1.5-1.5}}
test pkg-2.18 {Tcl_PkgRequire procedure, version checks} {
package forget t
package provide t 2.3
@@ -280,7 +280,7 @@
package forget t
package provide t 2.3
list [catch {package require -exact t 2.2} msg] $msg
-} {1 {version conflict for package "t": have 2.3, need 2.2-2.3}}
+} {1 {version conflict for package "t": have 2.3, need exactly 2.2}}
test pkg-2.25 {Tcl_PkgRequire procedure, error in ifneeded script} -body {
package forget t
package ifneeded t 2.1 {package provide t 2.1; error "ifneeded test" EI}
@@ -482,7 +482,13 @@
package forget foo
package unknown $saveUnknown
} -returnCodes error -match glob -result {bad return code:*}
-
+test pkg-2.44 {Tcl_PkgRequire: exact version matching (1578344)} -setup {
+ package provide demo 1.2.3
+} -body {
+ package require -exact demo 1.2
+} -cleanup {
+ package forget demo
+} -returnCodes error -result {version conflict for package "demo": have 1.2.3, need exactly 1.2}
test pkg-2.50 {Tcl_PkgRequire procedure, picking best stable version} {
