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

1 files changed, 57 insertions, 188 deletions

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