* 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].

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