Preparation to provide TclNRPackageObjectCmd: Eliminate the loop in

PkgRequireCore so that TclNRAddCallback can be added at the needed spots.

2 files changed, 264 insertions, 262 deletions

diff --git a/generic/tclInt.h b/generic/tclInt.h
index 4967cd3..ac67ebd 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2750,6 +2750,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRForObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRForeachCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRIfObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRLmapCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRPackageObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRSourceObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRSubstObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRSwitchObjCmd;
diff --git a/generic/tclPkg.c b/generic/tclPkg.c
index 6a246bb..b48e71b 100644
--- a/generic/tclPkg.c
+++ b/generic/tclPkg.c
@@ -72,6 +72,8 @@ static Package *	FindPackage(Tcl_Interp *interp, const char *name);
 static int		PkgRequireCore(Tcl_Interp *interp, const char *name,
 			    int reqc, Tcl_Obj *const reqv[],
 			    void *clientDataPtr);
+static int		SelectPackage (Tcl_Interp *interp, const char *name,
+			    Package *pkgPtr, int reqc, Tcl_Obj *const reqv[]);
 
 /*
  * Helper macros.
@@ -351,329 +353,328 @@ PkgRequireCore(
 				 * available. */
     void *clientDataPtr)
 {
-    Interp *iPtr = (Interp *) interp;
     Package *pkgPtr;
-    PkgAvail *availPtr, *bestPtr, *bestStablePtr;
-    char *availVersion, *bestVersion, *bestStableVersion;
-				/* Internal rep. of versions */
-    int availStable, code, satisfies, pass;
+    int code, satisfies;
     char *script, *pkgVersionI;
     Tcl_DString command;
 
+    pkgPtr = FindPackage(interp, name);
+    if (pkgPtr->version == NULL) {
+	code = SelectPackage(interp, name, pkgPtr, reqc, reqv);
+	if (code != TCL_OK) {
+	    return code;
+	}
+	if (pkgPtr->version == NULL) {
+		/*
+		 * The package is not in the database. If there is a "package unknown"
+		 * command, invoke it.
+		 */
+
+		script = ((Interp *) interp)->packageUnknown;
+		if (script != NULL) {
+		    Tcl_DStringInit(&command);
+		    Tcl_DStringAppend(&command, script, -1);
+		    Tcl_DStringAppendElement(&command, name);
+		    AddRequirementsToDString(&command, reqc, reqv);
+
+		    code = Tcl_EvalEx(interp, Tcl_DStringValue(&command),
+			    Tcl_DStringLength(&command), TCL_EVAL_GLOBAL);
+		    Tcl_DStringFree(&command);
+
+		    if ((code != TCL_OK) && (code != TCL_ERROR)) {
+			Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+				"bad return code: %d", code));
+			Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL);
+			code = TCL_ERROR;
+		    }
+		    if (code == TCL_ERROR) {
+			Tcl_AddErrorInfo(interp,
+				"\n    (\"package unknown\" script)");
+			return code;
+		    }
+		    Tcl_ResetResult(interp);
+		}
+		/* pkgPtr may now be invalid, so refresh it. */
+		pkgPtr = FindPackage(interp, name);
+		code = SelectPackage(interp, name, pkgPtr, reqc, reqv);
+		if (code != TCL_OK) {
+		    return code;
+		}
+	}
+    }
+
+    if (pkgPtr->version == NULL) {
+	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		"can't find package %s", name));
+	Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", NULL);
+	AddRequirementsToResult(interp, reqc, reqv);
+	return TCL_ERROR;
+    }
+
     /*
-     * It can take up to three passes to find the package: one pass to run the
-     * "package unknown" script, one to run the "package ifneeded" script for
-     * a specific version, and a final pass to lookup the package loaded by
-     * the "package ifneeded" script.
+     * Ensure that the provided version meets the current requirements.
      */
 
-    for (pass=1 ;; pass++) {
-	pkgPtr = FindPackage(interp, name);
-	if (pkgPtr->version != NULL) {
-	    break;
-	}
+    if (reqc != 0) {
+	CheckVersionAndConvert(interp, pkgPtr->version, &pkgVersionI, NULL);
+	satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv);
 
-	/*
-	 * Check whether we're already attempting to load some version of this
-	 * package (circular dependency detection).
-	 */
+	ckfree(pkgVersionI);
 
-	if (pkgPtr->clientData != NULL) {
+	if (!satisfies) {
 	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
-		    "circular package dependency:"
-		    " attempt to provide %s %s requires %s",
-		    name, (char *) pkgPtr->clientData, name));
+		    "version conflict for package \"%s\": have %s, need",
+		    name, pkgPtr->version));
+	    Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT",
+		    NULL);
 	    AddRequirementsToResult(interp, reqc, reqv);
-	    Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", NULL);
 	    return TCL_ERROR;
 	}
+    }
 
-	/*
-	 * The package isn't yet present. Search the list of available
-	 * versions and invoke the script for the best available version. We
-	 * are actually locating the best, and the best stable version. One of
-	 * them is then chosen based on the selection mode.
-	 */
-
-	bestPtr = NULL;
-	bestStablePtr = NULL;
-	bestVersion = NULL;
-	bestStableVersion = NULL;
+    if (clientDataPtr) {
+	const void **ptr = (const void **) clientDataPtr;
 
-	for (availPtr = pkgPtr->availPtr; availPtr != NULL;
-		availPtr = availPtr->nextPtr) {
-	    if (CheckVersionAndConvert(interp, availPtr->version,
-		    &availVersion, &availStable) != TCL_OK) {
-		/*
-		 * The provided version number has invalid syntax. This
-		 * should not happen. This should have been caught by the
-		 * 'package ifneeded' registering the package.
-		 */
+	*ptr = pkgPtr->clientData;
+    }
+    Tcl_SetObjResult(interp, Tcl_NewStringObj(pkgPtr->version, -1));
+    return TCL_OK;
+}
+
+int SelectPackage (Tcl_Interp *interp, const char *name, Package *pkgPtr, int reqc, Tcl_Obj *const reqv[]) {
+    PkgAvail *availPtr, *bestPtr, *bestStablePtr;
+    char *availVersion, *bestVersion, *bestStableVersion;
+				/* Internal rep. of versions */
+    char *script;
+    int availStable, code, satisfies; 
+    Interp *iPtr = (Interp *) interp;
 
-		continue;
-	    }
+    /*
+     * Check whether we're already attempting to load some version of this
+     * package (circular dependency detection).
+     */
 
-	    /* Check satisfaction of requirements before considering the current version further. */
-	    if (reqc > 0) {
-		satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv);
-		if (!satisfies) {
-		    ckfree(availVersion);
-		    availVersion = NULL;
-		    continue;
-		}
-	    }
+    if (pkgPtr->clientData != NULL) {
+	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		"circular package dependency:"
+		" attempt to provide %s %s requires %s",
+		name, (char *) pkgPtr->clientData, name));
+	AddRequirementsToResult(interp, reqc, reqv);
+	Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", NULL);
+	return TCL_ERROR;
+    }
 
-	    if (bestPtr != NULL) {
-		int res = CompareVersions(availVersion, bestVersion, NULL);
+    /*
+     * The package isn't yet present. Search the list of available
+     * versions and invoke the script for the best available version. We
+     * are actually locating the best, and the best stable version. One of
+     * them is then chosen based on the selection mode.
+     */
 
-		/*
-		 * Note: Used internal reps in the comparison!
-		 */
+    bestPtr = NULL;
+    bestStablePtr = NULL;
+    bestVersion = NULL;
+    bestStableVersion = NULL;
 
-		if (res > 0) {
-		    /*
-		     * The version of the package sought is better than the
-		     * currently selected version.
-		     */
-		    ckfree(bestVersion);
-		    bestVersion = NULL;
-		    goto newbest;
-		}
-	    } else {
-	    newbest:
-		/* We have found a version which is better than our max. */
+    for (availPtr = pkgPtr->availPtr; availPtr != NULL;
+	    availPtr = availPtr->nextPtr) {
+	if (CheckVersionAndConvert(interp, availPtr->version,
+		&availVersion, &availStable) != TCL_OK) {
+	    /*
+	     * The provided version number has invalid syntax. This
+	     * should not happen. This should have been caught by the
+	     * 'package ifneeded' registering the package.
+	     */
 
-		bestPtr = availPtr;
-		CheckVersionAndConvert(interp, bestPtr->version, &bestVersion, NULL);
-	    }
+	    continue;
+	}
 
-	    if (!availStable) {
+	/* Check satisfaction of requirements before considering the current version further. */
+	if (reqc > 0) {
+	    satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv);
+	    if (!satisfies) {
 		ckfree(availVersion);
 		availVersion = NULL;
 		continue;
 	    }
+	}
 
-	    if (bestStablePtr != NULL) {
-		int res = CompareVersions(availVersion, bestStableVersion, NULL);
+	if (bestPtr != NULL) {
+	    int res = CompareVersions(availVersion, bestVersion, NULL);
+
+	    /*
+	     * Note: Used internal reps in the comparison!
+	     */
 
+	    if (res > 0) {
 		/*
-		 * Note: Used internal reps in the comparison!
+		 * The version of the package sought is better than the
+		 * currently selected version.
 		 */
-
-		if (res > 0) {
-		    /*
-		     * This stable version of the package sought is better
-		     * than the currently selected stable version.
-		     */
-		    ckfree(bestStableVersion);
-		    bestStableVersion = NULL;
-		    goto newstable;
-		}
-	    } else {
-	    newstable:
-		/* We have found a stable version which is better than our max stable. */
-		bestStablePtr = availPtr;
-		CheckVersionAndConvert(interp, bestStablePtr->version, &bestStableVersion, NULL);
+		ckfree(bestVersion);
+		bestVersion = NULL;
+		goto newbest;
 	    }
+	} else {
+	newbest:
+	    /* We have found a version which is better than our max. */
 
-	    ckfree(availVersion);
-	    availVersion = NULL;
-	} /* end for */
-
-	/*
-	 * Clean up memorized internal reps, if any.
-	 */
-
-	if (bestVersion != NULL) {
-	    ckfree(bestVersion);
-	    bestVersion = NULL;
+	    bestPtr = availPtr;
+	    CheckVersionAndConvert(interp, bestPtr->version, &bestVersion, NULL);
 	}
 
-	if (bestStableVersion != NULL) {
-	    ckfree(bestStableVersion);
-	    bestStableVersion = NULL;
+	if (!availStable) {
+	    ckfree(availVersion);
+	    availVersion = NULL;
+	    continue;
 	}
 
-	/*
-	 * Now choose a version among the two best. For 'latest' we simply
-	 * take (actually keep) the best. For 'stable' we take the best
-	 * stable, if there is any, or the best if there is nothing stable.
-	 */
+	if (bestStablePtr != NULL) {
+	    int res = CompareVersions(availVersion, bestStableVersion, NULL);
 
-	if ((iPtr->packagePrefer == PKG_PREFER_STABLE)
-		&& (bestStablePtr != NULL)) {
-	    bestPtr = bestStablePtr;
-	}
-
-	if (bestPtr != NULL) {
 	    /*
-	     * We found an ifneeded script for the package. Be careful while
-	     * executing it: this could cause reentrancy, so (a) protect the
-	     * script itself from deletion and (b) don't assume that bestPtr
-	     * will still exist when the script completes.
+	     * Note: Used internal reps in the comparison!
 	     */
 
-	    char *versionToProvide = bestPtr->version;
-	    script = bestPtr->script;
-
-	    pkgPtr->clientData = versionToProvide;
-	    Tcl_Preserve(script);
-	    Tcl_Preserve(versionToProvide);
-	    code = Tcl_EvalEx(interp, script, -1, TCL_EVAL_GLOBAL);
-	    Tcl_Release(script);
-
-	    pkgPtr = FindPackage(interp, name);
-	    if (code == TCL_OK) {
-		Tcl_ResetResult(interp);
-		if (pkgPtr->version == NULL) {
-		    code = TCL_ERROR;
-		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
-			    "attempt to provide package %s %s failed:"
-			    " no version of package %s provided",
-			    name, versionToProvide, name));
-		    Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED",
-			    NULL);
-		} else {
-		    char *pvi, *vi;
-
-		    if (CheckVersionAndConvert(interp, pkgPtr->version, &pvi,
-			    NULL) != TCL_OK) {
-			code = TCL_ERROR;
-		    } else if (CheckVersionAndConvert(interp,
-			    versionToProvide, &vi, NULL) != TCL_OK) {
-			ckfree(pvi);
-			code = TCL_ERROR;
-		    } else {
-			int res = CompareVersions(pvi, vi, NULL);
-
-			ckfree(pvi);
-			ckfree(vi);
-			if (res != 0) {
-			    code = TCL_ERROR;
-			    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
-				    "attempt to provide package %s %s failed:"
-				    " package %s %s provided instead",
-				    name, versionToProvide,
-				    name, pkgPtr->version));
-			    Tcl_SetErrorCode(interp, "TCL", "PACKAGE",
-				    "WRONGPROVIDE", NULL);
-			}
-		    }
-		}
-	    } else if (code != TCL_ERROR) {
-		Tcl_Obj *codePtr = Tcl_NewIntObj(code);
-
-		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
-			"attempt to provide package %s %s failed:"
-			" bad return code: %s",
-			name, versionToProvide, TclGetString(codePtr)));
-		Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL);
-		TclDecrRefCount(codePtr);
-		code = TCL_ERROR;
-	    }
-
-	    if (code == TCL_ERROR) {
-		Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
-			"\n    (\"package ifneeded %s %s\" script)",
-			name, versionToProvide));
-	    }
-	    Tcl_Release(versionToProvide);
-
-	    if (code != TCL_OK) {
+	    if (res > 0) {
 		/*
-		 * Take a non-TCL_OK code from the script as an indication the
-		 * package wasn't loaded properly, so the package system
-		 * should not remember an improper load.
-		 *
-		 * This is consistent with our returning NULL. If we're not
-		 * willing to tell our caller we got a particular version, we
-		 * shouldn't store that version for telling future callers
-		 * either.
+		 * This stable version of the package sought is better
+		 * than the currently selected stable version.
 		 */
-
-		if (pkgPtr->version != NULL) {
-		    ckfree(pkgPtr->version);
-		    pkgPtr->version = NULL;
-		}
-		pkgPtr->clientData = NULL;
-		return code;
+		ckfree(bestStableVersion);
+		bestStableVersion = NULL;
+		goto newstable;
 	    }
-
-	    break;
-	}
-
-	/*
-	 * The package is not in the database. If there is a "package unknown"
-	 * command, invoke it (but only on the first pass; after that, we
-	 * should not get here in the first place).
-	 */
-
-	if (pass > 1) {
-	    break;
+	} else {
+	newstable:
+	    /* We have found a stable version which is better than our max stable. */
+	    bestStablePtr = availPtr;
+	    CheckVersionAndConvert(interp, bestStablePtr->version, &bestStableVersion, NULL);
 	}
 
-	script = ((Interp *) interp)->packageUnknown;
-	if (script != NULL) {
-	    Tcl_DStringInit(&command);
-	    Tcl_DStringAppend(&command, script, -1);
-	    Tcl_DStringAppendElement(&command, name);
-	    AddRequirementsToDString(&command, reqc, reqv);
+	ckfree(availVersion);
+	availVersion = NULL;
+    } /* end for */
 
-	    code = Tcl_EvalEx(interp, Tcl_DStringValue(&command),
-		    Tcl_DStringLength(&command), TCL_EVAL_GLOBAL);
-	    Tcl_DStringFree(&command);
+    /*
+     * Clean up memorized internal reps, if any.
+     */
 
-	    if ((code != TCL_OK) && (code != TCL_ERROR)) {
-		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
-			"bad return code: %d", code));
-		Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL);
-		code = TCL_ERROR;
-	    }
-	    if (code == TCL_ERROR) {
-		Tcl_AddErrorInfo(interp,
-			"\n    (\"package unknown\" script)");
-		return code;
-	    }
-	    Tcl_ResetResult(interp);
-	}
+    if (bestVersion != NULL) {
+	ckfree(bestVersion);
+	bestVersion = NULL;
     }
 
-    if (pkgPtr->version == NULL) {
-	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
-		"can't find package %s", name));
-	Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", NULL);
-	AddRequirementsToResult(interp, reqc, reqv);
-	return TCL_ERROR;
+    if (bestStableVersion != NULL) {
+	ckfree(bestStableVersion);
+	bestStableVersion = NULL;
     }
 
     /*
-     * At this point we know that the package is present. Make sure that the
-     * provided version meets the current requirements.
+     * Now choose a version among the two best. For 'latest' we simply
+     * take (actually keep) the best. For 'stable' we take the best
+     * stable, if there is any, or the best if there is nothing stable.
      */
 
-    if (reqc != 0) {
-	CheckVersionAndConvert(interp, pkgPtr->version, &pkgVersionI, NULL);
-	satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv);
+    if ((iPtr->packagePrefer == PKG_PREFER_STABLE)
+	    && (bestStablePtr != NULL)) {
+	bestPtr = bestStablePtr;
+    }
 
-	ckfree(pkgVersionI);
+    if (bestPtr != NULL) {
+	/*
+	 * We found an ifneeded script for the package. Be careful while
+	 * executing it: this could cause reentrancy, so (a) protect the
+	 * script itself from deletion and (b) don't assume that bestPtr
+	 * will still exist when the script completes.
+	 */
+
+	char *versionToProvide = bestPtr->version;
+	script = bestPtr->script;
+
+	pkgPtr->clientData = versionToProvide;
+	Tcl_Preserve(script);
+	Tcl_Preserve(versionToProvide);
+	code = Tcl_EvalEx(interp, script, -1, TCL_EVAL_GLOBAL);
+	Tcl_Release(script);
+
+	pkgPtr = FindPackage(interp, name);
+	if (code == TCL_OK) {
+	    Tcl_ResetResult(interp);
+	    if (pkgPtr->version == NULL) {
+		code = TCL_ERROR;
+		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+			"attempt to provide package %s %s failed:"
+			" no version of package %s provided",
+			name, versionToProvide, name));
+		Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED",
+			NULL);
+	    } else {
+		char *pvi, *vi;
+
+		if (CheckVersionAndConvert(interp, pkgPtr->version, &pvi,
+			NULL) != TCL_OK) {
+		    code = TCL_ERROR;
+		} else if (CheckVersionAndConvert(interp,
+			versionToProvide, &vi, NULL) != TCL_OK) {
+		    ckfree(pvi);
+		    code = TCL_ERROR;
+		} else {
+		    int res = CompareVersions(pvi, vi, NULL);
+
+		    ckfree(pvi);
+		    ckfree(vi);
+		    if (res != 0) {
+			code = TCL_ERROR;
+			Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+				"attempt to provide package %s %s failed:"
+				" package %s %s provided instead",
+				name, versionToProvide,
+				name, pkgPtr->version));
+			Tcl_SetErrorCode(interp, "TCL", "PACKAGE",
+				"WRONGPROVIDE", NULL);
+		    }
+		}
+	    }
+	} else if (code != TCL_ERROR) {
+	    Tcl_Obj *codePtr = Tcl_NewIntObj(code);
 
-	if (!satisfies) {
 	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
-		    "version conflict for package \"%s\": have %s, need",
-		    name, pkgPtr->version));
-	    Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT",
-		    NULL);
-	    AddRequirementsToResult(interp, reqc, reqv);
-	    return TCL_ERROR;
+		    "attempt to provide package %s %s failed:"
+		    " bad return code: %s",
+		    name, versionToProvide, TclGetString(codePtr)));
+	    Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL);
+	    TclDecrRefCount(codePtr);
+	    code = TCL_ERROR;
 	}
-    }
 
-    if (clientDataPtr) {
-	const void **ptr = (const void **) clientDataPtr;
+	if (code == TCL_ERROR) {
+	    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+		    "\n    (\"package ifneeded %s %s\" script)",
+		    name, versionToProvide));
+	}
+	Tcl_Release(versionToProvide);
 
-	*ptr = pkgPtr->clientData;
+	if (code != TCL_OK) {
+	    /*
+	     * Take a non-TCL_OK code from the script as an indication the
+	     * package wasn't loaded properly, so the package system
+	     * should not remember an improper load.
+	     *
+	     * This is consistent with our returning NULL. If we're not
+	     * willing to tell our caller we got a particular version, we
+	     * shouldn't store that version for telling future callers
+	     * either.
+	     */
+
+	    if (pkgPtr->version != NULL) {
+		ckfree(pkgPtr->version);
+		pkgPtr->version = NULL;
+	    }
+	    pkgPtr->clientData = NULL;
+	    return code;
+	}
     }
-    Tcl_SetObjResult(interp, Tcl_NewStringObj(pkgPtr->version, -1));
     return TCL_OK;
 }