merge 8.7

4 files changed, 68 insertions, 22 deletions

diff --git a/generic/tclPkg.c b/generic/tclPkg.c
index 8966387..2e5cf0b 100644
--- a/generic/tclPkg.c
+++ b/generic/tclPkg.c
@@ -56,10 +56,7 @@ typedef struct PkgFiles {
  */
 
 typedef struct {
-    char *version;		/* Version that has been supplied in this
-				 * interpreter via "package provide"
-				 * (malloc'ed). NULL means the package doesn't
-				 * exist in this interpreter yet. */
+    Tcl_Obj *version;
     PkgAvail *availPtr;		/* First in list of all available versions of
 				 * this package. */
     const void *clientData;	/* Client data. */
@@ -166,12 +163,13 @@ Tcl_PkgProvideEx(
 
     pkgPtr = FindPackage(interp, name);
     if (pkgPtr->version == NULL) {
-	DupString(pkgPtr->version, version);
+	pkgPtr->version = Tcl_NewStringObj(version, -1);
+	Tcl_IncrRefCount(pkgPtr->version);
 	pkgPtr->clientData = clientData;
 	return TCL_OK;
     }
 
-    if (CheckVersionAndConvert(interp, pkgPtr->version, &pvi,
+    if (CheckVersionAndConvert(interp, Tcl_GetString(pkgPtr->version), &pvi,
 	    NULL) != TCL_OK) {
 	return TCL_ERROR;
     } else if (CheckVersionAndConvert(interp, version, &vi, NULL) != TCL_OK) {
@@ -191,7 +189,7 @@ Tcl_PkgProvideEx(
     }
     Tcl_SetObjResult(interp, Tcl_ObjPrintf(
 	    "conflicting versions provided for package \"%s\": %s, then %s",
-	    name, pkgPtr->version, version));
+	    name, Tcl_GetString(pkgPtr->version), version));
     Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", NULL);
     return TCL_ERROR;
 }
@@ -384,7 +382,7 @@ Tcl_PkgRequireEx(
 
     if (version == NULL) {
 	if (Tcl_PkgRequireProc(interp, name, 0, NULL, clientDataPtr) == TCL_OK) {
-	    result = Tcl_GetStringResult(interp);
+	    result = Tcl_GetString(Tcl_GetObjResult(interp));
 	    Tcl_ResetResult(interp);
 	}
     } else {
@@ -398,7 +396,7 @@ Tcl_PkgRequireEx(
 	}
 	Tcl_IncrRefCount(ov);
 	if (Tcl_PkgRequireProc(interp, name, 1, &ov, clientDataPtr) == TCL_OK) {
-	    result = Tcl_GetStringResult(interp);
+	    result = Tcl_GetString(Tcl_GetObjResult(interp));
 	    Tcl_ResetResult(interp);
 	}
 	TclDecrRefCount(ov);
@@ -540,7 +538,8 @@ PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result) {
      */
 
     if (reqc != 0) {
-	CheckVersionAndConvert(interp, reqPtr->pkgPtr->version, &pkgVersionI, NULL);
+	CheckVersionAndConvert(interp, Tcl_GetString(reqPtr->pkgPtr->version),
+		&pkgVersionI, NULL);
 	satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv);
 
 	Tcl_Free(pkgVersionI);
@@ -548,7 +547,7 @@ PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result) {
 	if (!satisfies) {
 	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
 		    "version conflict for package \"%s\": have %s, need",
-		    name, reqPtr->pkgPtr->version));
+		    name, Tcl_GetString(reqPtr->pkgPtr->version)));
 	    Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT",
 		    NULL);
 	    AddRequirementsToResult(interp, reqc, reqv);
@@ -561,7 +560,7 @@ PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result) {
 
 	*ptr = reqPtr->pkgPtr->clientData;
     }
-    Tcl_SetObjResult(interp, Tcl_NewStringObj(reqPtr->pkgPtr->version, -1));
+    Tcl_SetObjResult(interp, reqPtr->pkgPtr->version);
     return TCL_OK;
 }
 
@@ -778,8 +777,8 @@ SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) {
 	} else {
 	    char *pvi, *vi;
 
-	    if (CheckVersionAndConvert(interp, reqPtr->pkgPtr->version, &pvi,
-		    NULL) != TCL_OK) {
+	    if (TCL_OK != CheckVersionAndConvert(interp,
+		    Tcl_GetString(reqPtr->pkgPtr->version), &pvi, NULL)) {
 		result = TCL_ERROR;
 	    } else if (CheckVersionAndConvert(interp,
 		    versionToProvide, &vi, NULL) != TCL_OK) {
@@ -796,7 +795,7 @@ SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) {
 			    "attempt to provide package %s %s failed:"
 			    " package %s %s provided instead",
 			    name, versionToProvide,
-			    name, reqPtr->pkgPtr->version));
+			    name, Tcl_GetString(reqPtr->pkgPtr->version)));
 		    Tcl_SetErrorCode(interp, "TCL", "PACKAGE",
 			    "WRONGPROVIDE", NULL);
 		}
@@ -834,7 +833,7 @@ SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) {
 	 */
 
 	if (reqPtr->pkgPtr->version != NULL) {
-	    Tcl_Free(reqPtr->pkgPtr->version);
+	    Tcl_DecrRefCount(reqPtr->pkgPtr->version);
 	    reqPtr->pkgPtr->version = NULL;
 	}
 	reqPtr->pkgPtr->clientData = NULL;
@@ -1036,7 +1035,7 @@ TclNRPackageObjCmd(
 	    pkgPtr = Tcl_GetHashValue(hPtr);
 	    Tcl_DeleteHashEntry(hPtr);
 	    if (pkgPtr->version != NULL) {
-		Tcl_Free(pkgPtr->version);
+		Tcl_DecrRefCount(pkgPtr->version);
 	    }
 	    while (pkgPtr->availPtr != NULL) {
 		availPtr = pkgPtr->availPtr;
@@ -1208,8 +1207,7 @@ TclNRPackageObjCmd(
 	    if (hPtr != NULL) {
 		pkgPtr = Tcl_GetHashValue(hPtr);
 		if (pkgPtr->version != NULL) {
-		    Tcl_SetObjResult(interp,
-			    Tcl_NewStringObj(pkgPtr->version, -1));
+		    Tcl_SetObjResult(interp, pkgPtr->version);
 		}
 	    }
 	    return TCL_OK;
@@ -1502,7 +1500,7 @@ TclFreePackageInfo(
 	    hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
 	pkgPtr = Tcl_GetHashValue(hPtr);
 	if (pkgPtr->version != NULL) {
-	    Tcl_Free(pkgPtr->version);
+	    Tcl_DecrRefCount(pkgPtr->version);
 	}
 	while (pkgPtr->availPtr != NULL) {
 	    availPtr = pkgPtr->availPtr;
diff --git a/generic/tclTestProcBodyObj.c b/generic/tclTestProcBodyObj.c
index 42fbea9..c453ae2 100644
--- a/generic/tclTestProcBodyObj.c
+++ b/generic/tclTestProcBodyObj.c
@@ -21,13 +21,14 @@
  */
 
 static const char packageName[] = "procbodytest";
-static const char packageVersion[] = "1.0";
+static const char packageVersion[] = "1.1";
 
 /*
  * Name of the commands exported by this package
  */
 
 static const char procCommand[] = "proc";
+static const char checkCommand[] = "check";
 
 /*
  * this struct describes an entry in the table of command names and command
@@ -46,6 +47,8 @@ typedef struct {
 
 static int	ProcBodyTestProcObjCmd(ClientData dummy,
 			Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
+static int	ProcBodyTestCheckObjCmd(ClientData dummy,
+			Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
 static int	ProcBodyTestInitInternal(Tcl_Interp *interp, int isSafe);
 static int	RegisterCommand(Tcl_Interp* interp,
 			const char *namespace, const CmdTable *cmdTablePtr);
@@ -57,11 +60,13 @@ static int	RegisterCommand(Tcl_Interp* interp,
 
 static const CmdTable commands[] = {
     { procCommand,	ProcBodyTestProcObjCmd,	1 },
+    { checkCommand,	ProcBodyTestCheckObjCmd,	1 },
     { 0, 0, 0 }
 };
 
 static const CmdTable safeCommands[] = {
     { procCommand,	ProcBodyTestProcObjCmd,	1 },
+    { checkCommand,	ProcBodyTestCheckObjCmd,	1 },
     { 0, 0, 0 }
 };
 
@@ -301,6 +306,46 @@ ProcBodyTestProcObjCmd(
 }
 
 /*
+ *----------------------------------------------------------------------
+ *
+ * ProcBodyTestCheckObjCmd --
+ *
+ *  Implements the "procbodytest::check" command. Here is the command
+ *  description:
+ *	procbodytest::check
+ *
+ *  Performs an internal check that the Tcl_PkgPresent() command returns
+ *  the same version number as was registered when the procbodytest package
+ *  was provided.  Places a boolean in the interp result indicating the
+ *  test outcome.
+ *
+ * Results:
+ *  Returns a standard Tcl code.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ProcBodyTestCheckObjCmd(
+    ClientData dummy,		/* context; not used */
+    Tcl_Interp *interp,		/* the current interpreter */
+    int objc,			/* argument count */
+    Tcl_Obj *const objv[])	/* arguments */
+{
+    const char *version;
+
+    if (objc != 1) {
+	Tcl_WrongNumArgs(interp, 1, objv, "");
+	return TCL_ERROR;
+    }
+
+    version = Tcl_PkgPresent(interp, packageName, packageVersion, 1);
+    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(
+	    strcmp(version, packageVersion) == 0));
+    return TCL_OK;
+}
+
+/*
  * Local Variables:
  * mode: c
  * c-basic-offset: 4
diff --git a/tests-perf/timer-event.perf.tcl b/tests-perf/timer-event.perf.tcl
index 805f0f8..c5a7d45 100644
--- a/tests-perf/timer-event.perf.tcl
+++ b/tests-perf/timer-event.perf.tcl
@@ -76,7 +76,7 @@ proc test-queue {{reptime {1000 10000}}} {
     # cancel forwards "after 0" / $howmuch timer-events in queue:
     setup {set i 0; timerate {set ev([incr i]) [after 0 {set foo bar}]} {*}$reptime}
     setup {set le $i; set i 0; list 1 .. $le; # cancel up to $howmuch events}
-    {after cancel $ev([incr i]); if {$i >= $howmuch} break}
+    {after cancel $ev([incr i]); if {$i >= $le} break}
     cleanup {update; unset -nocomplain ev}
     # cancel backwards "after 0" / $howmuch timer-events in queue:
     setup {set i 0; timerate {set ev([incr i]) [after 0 {set foo bar}]} {*}$reptime}
diff --git a/tests/proc.test b/tests/proc.test
index 1893d0f..43d76d8 100644
--- a/tests/proc.test
+++ b/tests/proc.test
@@ -321,6 +321,9 @@ test proc-4.8 {TclCreateProc, procbody obj, no leak on multiple iterations} -set
     rename getbytes {}
     unset -nocomplain end i tmp leakedBytes
 } -result 0
+test proc-4.9 {[39fed4dae5] Valid Tcl_PkgPresent return} procbodytest {
+    procbodytest::check
+} 1
 
 test proc-5.1 {Bytecompiling noop; test for correct argument substitution} -body {
     proc p args {} ; # this will be bytecompiled into t