From 4c79bcbe64fca55bf859f1fb9a78bf887d7c78dc Mon Sep 17 00:00:00 2001 From: pooryorick Date: Mon, 12 Feb 2018 10:14:02 +0000 Subject: Preparation to provide TclNRPackageObjectCmd: Eliminate the loop in PkgRequireCore so that TclNRAddCallback can be added at the needed spots. --- generic/tclInt.h | 1 + generic/tclPkg.c | 525 ++++++++++++++++++++++++++++--------------------------- 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; } -- cgit v0.12