summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2007-09-11 17:46:05 (GMT)
committerdgp <dgp@users.sourceforge.net>2007-09-11 17:46:05 (GMT)
commit05d4bff61c4b959be0020c6a2b74a82cddb1e71e (patch)
treef9882b020d2a79da2aa09179a4c91ed93282b18f
parent7ad8b091dd878126106f9c18e855d17909f1068c (diff)
downloadtcl-05d4bff61c4b959be0020c6a2b74a82cddb1e71e.zip
tcl-05d4bff61c4b959be0020c6a2b74a82cddb1e71e.tar.gz
tcl-05d4bff61c4b959be0020c6a2b74a82cddb1e71e.tar.bz2
* doc/package.n: Restored the functioning of
* generic/tclPkg.c: [package require -exact] to be compatible * tests/pkg.test: with Tcl 8.4. [Bug 1578344].
-rw-r--r--ChangeLog6
-rw-r--r--doc/package.n29
-rw-r--r--generic/tclPkg.c245
-rw-r--r--tests/pkg.test20
4 files changed, 87 insertions, 213 deletions
diff --git a/ChangeLog b/ChangeLog
index 3a58c75..d025ac7 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2007-09-11 Don Porter <dgp@users.sourceforge.net>
+
+ * doc/package.n: Restored the functioning of
+ * generic/tclPkg.c: [package require -exact] to be compatible
+ * tests/pkg.test: with Tcl 8.4. [Bug 1578344].
+
2007-09-11 Miguel Sofer <msofer@users.sf.net>
* generic/tclCompCmds.c (TclCompileDictCmd-update):
diff --git a/doc/package.n b/doc/package.n
index 6231a1f..5db0f2f 100644
--- a/doc/package.n
+++ b/doc/package.n
@@ -4,7 +4,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" RCS: @(#) $Id: package.n,v 1.16 2007/09/10 14:59:55 dgp Exp $
+'\" RCS: @(#) $Id: package.n,v 1.17 2007/09/11 17:46:07 dgp Exp $
'\"
.so man.macros
.TH package n 7.5 Tcl "Tcl Built-In Commands"
@@ -17,9 +17,11 @@ package \- Facilities for package loading and version control
\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 @@ interpreter for which a version has been provided (via
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 @@ returns the version number that is currently provided, or an
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 @@ If all of these steps fail to provide an acceptable version of the
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
diff --git a/generic/tclPkg.c b/generic/tclPkg.c
index a534021..8fc4d9f 100644
--- a/generic/tclPkg.c
+++ b/generic/tclPkg.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclPkg.c,v 1.28 2007/09/10 14:59:56 dgp Exp $
+ * RCS: @(#) $Id: tclPkg.c,v 1.29 2007/09/11 17:46:07 dgp Exp $
*
* TIP #268.
* Heavily rewritten to handle the extend version numbers, and extended
@@ -64,16 +64,16 @@ static int CheckRequirement(Tcl_Interp *interp,
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 const char * PkgRequireCore(Tcl_Interp *interp, CONST char *name,
+ int reqc, Tcl_Obj *CONST reqv[],
+ ClientData *clientDataPtr);
/*
* Helper macros.
@@ -218,7 +218,7 @@ Tcl_PkgRequireEx(
* 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,53 +294,47 @@ Tcl_PkgRequireEx(
/* 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;
- }
+ return result;
+}
- /*
- * 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.
- */
+int
+Tcl_PkgRequireProc(
+ 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)
+{
+ const char *result =
+ PkgRequireCore(interp, name, reqc, reqv, clientDataPtr);
- ov = (Tcl_Obj *) Tcl_GetAssocData(interp, "tcl/Tcl_PkgRequireEx", NULL);
- if (ov != NULL) {
- TclDecrRefCount(ov);
+ if (result == NULL) {
+ return TCL_ERROR;
}
-
- ov = Tcl_GetObjResult(interp);
- Tcl_IncrRefCount(ov);
- Tcl_SetAssocData(interp, "tcl/Tcl_PkgRequireEx", VersionCleanupProc, ov);
- Tcl_ResetResult(interp);
-
- return TclGetString(ov);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(result, -1));
+ return TCL_OK;
}
-int
-Tcl_PkgRequireProc(
+static const char *
+PkgRequireCore(
Tcl_Interp *interp, /* Interpreter in which package is now
* available. */
CONST char *name, /* Name of desired package. */
@@ -384,7 +378,7 @@ Tcl_PkgRequireProc(
"attempt to provide ", name, " ",
(char *) pkgPtr->clientData, " requires ", name, NULL);
AddRequirementsToResult(interp, reqc, reqv);
- return TCL_ERROR;
+ return NULL;
}
/*
@@ -436,7 +430,7 @@ Tcl_PkgRequireProc(
* Check satisfaction of requirements.
*/
- satisfies = AllRequirementsSatisfied(availVersion,reqc,reqv);
+ satisfies = SomeRequirementSatisfied(availVersion,reqc,reqv);
if (!satisfies) {
ckfree(availVersion);
availVersion = NULL;
@@ -562,7 +556,7 @@ Tcl_PkgRequireProc(
pkgPtr->version = NULL;
}
pkgPtr->clientData = NULL;
- return TCL_ERROR;
+ return NULL;
}
break;
@@ -600,7 +594,7 @@ Tcl_PkgRequireProc(
if (code == TCL_ERROR) {
Tcl_AddErrorInfo(interp,
"\n (\"package unknown\" script)");
- return TCL_ERROR;
+ return NULL;
}
Tcl_ResetResult(interp);
}
@@ -609,7 +603,7 @@ Tcl_PkgRequireProc(
if (pkgPtr->version == NULL) {
Tcl_AppendResult(interp, "can't find package ", name, NULL);
AddRequirementsToResult(interp, reqc, reqv);
- return TCL_ERROR;
+ return NULL;
}
/*
@@ -621,7 +615,7 @@ Tcl_PkgRequireProc(
satisfies = 1;
} else {
CheckVersionAndConvert(interp, pkgPtr->version, &pkgVersionI, NULL);
- satisfies = AllRequirementsSatisfied(pkgVersionI, reqc, reqv);
+ satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv);
ckfree(pkgVersionI);
}
@@ -630,14 +624,13 @@ Tcl_PkgRequireProc(
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 +970,8 @@ Tcl_PackageObjCmd(
* 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 +1108,7 @@ Tcl_PackageObjCmd(
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 +1636,15 @@ AddRequirementsToResult(
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 +1688,7 @@ AddRequirementsToDString(
/*
*----------------------------------------------------------------------
*
- * AllRequirementSatisfied --
+ * SomeRequirementSatisfied --
*
* This function checks to see whether a version satisfies at least one
* of a set of requirements.
@@ -1703,7 +1705,7 @@ AddRequirementsToDString(
*/
static int
-AllRequirementsSatisfied(
+SomeRequirementSatisfied(
char *availVersionI, /* Candidate version to check against the
* requirements. */
int reqc, /* Requirements constraining the desired
@@ -1823,139 +1825,6 @@ RequirementSatisfied(
}
/*
- *----------------------------------------------------------------------
- *
- * ExactRequirement --
- *
- * 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.
- *
- * Results:
- * A Tcl_Obj containing the version range as string.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static Tcl_Obj *
-ExactRequirement(
- 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;
- Tcl_Obj *objPtr = Tcl_NewStringObj(version, -1);
-
- Tcl_AppendStringsToObj(objPtr, "-", NULL);
-
- /*
- * Assuming valid syntax here.
- */
-
- CheckVersionAndConvert(NULL, version, &iv, NULL);
-
- /*
- * Split the list into components.
- */
-
- Tcl_SplitList(NULL, iv, &lc, &lv);
-
- /*
- * Iterate over the components and make them parts of the result. Except
- * for the last, which is handled separately, to allow the incrementation.
- */
-
- for (i=0; i < (lc-1); i++) {
- /*
- * Regular component.
- */
-
- Tcl_AppendStringsToObj(objPtr, lv[i], NULL);
-
- /*
- * Separator component.
- */
-
- i++;
- if (0 == strcmp("-1", lv[i])) {
- Tcl_AppendStringsToObj(objPtr, "b", NULL);
- } else if (0 == strcmp("-2", lv[i])) {
- Tcl_AppendStringsToObj(objPtr, "a", NULL);
- } else {
- Tcl_AppendStringsToObj(objPtr, ".", NULL);
- }
- }
-
- /*
- * Regular component, last.
- */
-
- sprintf(buf, "%d", atoi(lv[lc-1]) + 1);
- Tcl_AppendStringsToObj(objPtr, buf, NULL);
-
- ckfree((char *) iv);
- ckfree((char *) lv);
- return objPtr;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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
diff --git a/tests/pkg.test b/tests/pkg.test
index f52cdad..fa4a942 100644
--- a/tests/pkg.test
+++ b/tests/pkg.test
@@ -11,7 +11,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: pkg.test,v 1.27 2007/09/10 14:59:56 dgp Exp $
+# RCS: @(#) $Id: pkg.test,v 1.28 2007/09/11 17:46:07 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
@@ -142,7 +142,7 @@ test pkg-2.8 {Tcl_PkgRequire procedure, can't find suitable version} {
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 @@ test pkg-2.13 {Tcl_PkgRequire procedure, "package unknown" support} {
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 @@ test pkg-2.17 {Tcl_PkgRequire procedure, "package unknown" doesn't load package}
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 @@ test pkg-2.24 {Tcl_PkgRequire procedure, version checks} {
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 @@ test pkg-2.43 {Tcl_PkgRequire: consistent return values (1162286)} -setup {
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 @@ test pkg-7.7 {Tcl_PkgPresent procedure, not exact version} {
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