Attachment "1578344-5.patch" to
ticket [1578344fff]
added by
dgp
2007-09-11 23:11:34.
Index: doc/package.n
===================================================================
RCS file: /cvsroot/tcl/tcl/doc/package.n,v
retrieving revision 1.16
diff -u -r1.16 package.n
--- doc/package.n 10 Sep 2007 14:59:55 -0000 1.16
+++ doc/package.n 11 Sep 2007 16:08:31 -0000
@@ -17,9 +17,11 @@
\fBpackage forget ?\fIpackage package ...\fR?
\fBpackage ifneeded \fIpackage version\fR ?\fIscript\fR?
\fBpackage names\fR
-\fBpackage present \fR?\fB\-exact\fR? \fIpackage \fR?\fIrequirement...\fR?
+\fBpackage present \fIpackage \fR?\fIrequirement...\fR?
+\fBpackage present \-exact \fIpackage version\fR
\fBpackage provide \fIpackage \fR?\fIversion\fR?
-\fBpackage require \fR?\fB\-exact\fR? \fIpackage \fR?\fIrequirement...\fR?
+\fBpackage require \fIpackage \fR?\fIrequirement...\fR?
+\fBpackage require \-exact \fIpackage version\fR
\fBpackage unknown \fR?\fIcommand\fR?
\fBpackage vcompare \fIversion1 version2\fR
\fBpackage versions \fIpackage\fR
@@ -77,7 +79,7 @@
script is available.
The order of elements in the list is arbitrary.
.TP
-\fBpackage present \fR?\fB\-exact\fR? \fIpackage \fR?\fIversion\fR?
+\fBpackage present\fR
This command is equivalent to \fBpackage require\fR except that it
does not try and load the package if it is not already loaded.
.TP
@@ -93,20 +95,6 @@
empty string if no \fBpackage provide\fR command has been
invoked for \fIpackage\fR in this interpreter.
.TP
-\fBpackage require \fR\fB\-exact\fR \fIpackage \fR\fIversion\fR
-This form of the command is translated to the form below using the
-bounded requirement "version-(version+1)", making only the given
-\fIversion\fR acceptable, within the specified level of detail. Deeper
-levels are allowed to vary. Examples:
-.CS
- -exact 8 => 8-9
- -exact 8.4 => 8.4-8.5
- -exact 8.4.14 => 8.4.14-8.4.15
-.CE
-.RS
-For more explanations see below.
-.RE
-.TP
\fBpackage require \fR\fIpackage \fR?\fIrequirement...\fR?
This command is typically invoked by Tcl code that wishes to use
a particular version of a particular package. The arguments
@@ -149,6 +137,11 @@
package, then the command returns an error.
.RE
.TP
+\fBpackage require \-exact \fIpackage version\fR
+This form of the command is used when only the given \fIversion\fR
+of \fIpackage\fR is acceptable to the caller. This command is
+equivalent to \fBpackage require \fIpackage version\fR-\fIversion\fR.
+.TP
\fBpackage unknown \fR?\fIcommand\fR?
This command supplies a ``last resort'' command to invoke during
\fBpackage require\fR if no suitable version of a package can be found
Index: generic/tclPkg.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclPkg.c,v
retrieving revision 1.28
diff -u -r1.28 tclPkg.c
--- generic/tclPkg.c 10 Sep 2007 14:59:56 -0000 1.28
+++ generic/tclPkg.c 11 Sep 2007 16:08:31 -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;
}
/*
@@ -977,7 +993,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]);
@@ -1114,7 +1131,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));
@@ -1642,7 +1659,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);
+ }
}
}
}
@@ -1686,7 +1711,7 @@
/*
*----------------------------------------------------------------------
*
- * AllRequirementSatisfied --
+ * SomeRequirementSatisfied --
*
* This function checks to see whether a version satisfies at least one
* of a set of requirements.
@@ -1703,7 +1728,7 @@
*/
static int
-AllRequirementsSatisfied(
+SomeRequirementSatisfied(
char *availVersionI, /* Candidate version to check against the
* requirements. */
int reqc, /* Requirements constraining the desired
@@ -1825,11 +1850,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.
@@ -1841,33 +1869,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;
@@ -1926,36 +1930,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: tests/pkg.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/pkg.test,v
retrieving revision 1.27
diff -u -r1.27 pkg.test
--- tests/pkg.test 10 Sep 2007 14:59:56 -0000 1.27
+++ tests/pkg.test 11 Sep 2007 16:08:33 -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} {
@@ -867,7 +873,7 @@
package forget t
package provide t 2.4
list [catch {package present -exact t 2.3} msg] $msg
-} {1 {version conflict for package "t": have 2.4, need 2.3-2.4}}
+} {1 {version conflict for package "t": have 2.4, need exactly 2.3}}
test pkg-7.8 {Tcl_PkgPresent procedure, unknown package} {
package forget t
list [catch {package present t} msg] $msg
