diff options
Diffstat (limited to 'generic/tclPkg.c')
| -rw-r--r-- | generic/tclPkg.c | 881 |
1 files changed, 514 insertions, 367 deletions
diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 349bda8..06d6ade 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -40,15 +40,24 @@ typedef struct PkgAvail { */ typedef struct Package { - 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. */ - ClientData clientData; /* Client data. */ + const void *clientData; /* Client data. */ } Package; +typedef struct Require { + void * clientDataPtr; + const char *name; + Package *pkgPtr; + char *versionToProvide; +} Require; + +typedef struct RequireProcArgs { + const char *name; + void *clientDataPtr; +} RequireProcArgs; + /* * Prototypes for functions defined in this file: */ @@ -69,9 +78,15 @@ static void AddRequirementsToResult(Tcl_Interp *interp, int reqc, static void AddRequirementsToDString(Tcl_DString *dstring, int reqc, Tcl_Obj *const reqv[]); static Package * FindPackage(Tcl_Interp *interp, const char *name); -static const char * PkgRequireCore(Tcl_Interp *interp, const char *name, - int reqc, Tcl_Obj *const reqv[], - ClientData *clientDataPtr); +static int PkgRequireCore(ClientData data[], Tcl_Interp *interp, int result); +static int PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result); +static int PkgRequireCoreCleanup(ClientData data[], Tcl_Interp *interp, int result); +static int PkgRequireCoreStep1(ClientData data[], Tcl_Interp *interp, int result); +static int PkgRequireCoreStep2(ClientData data[], Tcl_Interp *interp, int result); +static int TclNRPkgRequireProc(ClientData clientData, Tcl_Interp *interp, int reqc, Tcl_Obj *const reqv[]); +static int SelectPackage(ClientData data[], Tcl_Interp *interp, int result); +static int SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result); +static int TclNRPackageObjCmdCleanup(ClientData data[], Tcl_Interp *interp, int result); /* * Helper macros. @@ -123,7 +138,7 @@ Tcl_PkgProvideEx( * available. */ const char *name, /* Name of package. */ const char *version, /* Version string for package. */ - ClientData clientData) /* clientdata for this package (normally used + const void *clientData) /* clientdata for this package (normally used * for C callback function table) */ { Package *pkgPtr; @@ -132,12 +147,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) { @@ -155,8 +171,10 @@ Tcl_PkgProvideEx( } return TCL_OK; } - Tcl_AppendResult(interp, "conflicting versions provided for package \"", - name, "\": ", pkgPtr->version, ", then ", version, NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "conflicting versions provided for package \"%s\": %s, then %s", + name, Tcl_GetString(pkgPtr->version), version)); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", NULL); return TCL_ERROR; } @@ -212,7 +230,7 @@ Tcl_PkgRequireEx( int exact, /* Non-zero means that only the particular * version given is acceptable. Zero means use * the latest compatible version. */ - ClientData *clientDataPtr) /* Used to return the client data for this + void *clientDataPtr) /* Used to return the client data for this * package. If it is NULL then the client data * is not returned. This is unchanged if this * call fails for any reason. */ @@ -285,9 +303,10 @@ Tcl_PkgRequireEx( */ tclEmptyStringRep = &tclEmptyString; - Tcl_AppendResult(interp, "Cannot load package \"", name, - "\" in standalone executable: This package is not " - "compiled with stub support", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "Cannot load package \"%s\" in standalone executable:" + " This package is not compiled with stub support", name)); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNSTUBBED", NULL); return NULL; } @@ -296,7 +315,10 @@ Tcl_PkgRequireEx( */ if (version == NULL) { - result = PkgRequireCore(interp, name, 0, NULL, clientDataPtr); + if (Tcl_PkgRequireProc(interp, name, 0, NULL, clientDataPtr) == TCL_OK) { + result = Tcl_GetString(Tcl_GetObjResult(interp)); + Tcl_ResetResult(interp); + } } else { if (exact && TCL_OK != CheckVersionAndConvert(interp, version, NULL, NULL)) { @@ -307,10 +329,12 @@ Tcl_PkgRequireEx( Tcl_AppendStringsToObj(ov, "-", version, NULL); } Tcl_IncrRefCount(ov); - result = PkgRequireCore(interp, name, 1, &ov, clientDataPtr); + if (Tcl_PkgRequireProc(interp, name, 1, &ov, clientDataPtr) == TCL_OK) { + result = Tcl_GetString(Tcl_GetObjResult(interp)); + Tcl_ResetResult(interp); + } TclDecrRefCount(ov); } - return result; } @@ -323,346 +347,417 @@ Tcl_PkgRequireProc( * version. */ Tcl_Obj *const reqv[], /* 0 means to use the latest version * available. */ - ClientData *clientDataPtr) + void *clientDataPtr) { - const char *result = - PkgRequireCore(interp, name, reqc, reqv, clientDataPtr); + RequireProcArgs args; + args.name = name; + args.clientDataPtr = clientDataPtr; + return Tcl_NRCallObjProc(interp, TclNRPkgRequireProc, (void *)&args, reqc, reqv); +} - if (result == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_NewStringObj(result, -1)); +static int +TclNRPkgRequireProc( + ClientData clientData, + Tcl_Interp *interp, + int reqc, + Tcl_Obj *const reqv[]) { + RequireProcArgs *args = clientData; + Tcl_NRAddCallback(interp, PkgRequireCore, (void *)args->name, INT2PTR(reqc), (void *)reqv, args->clientDataPtr); return TCL_OK; } -static const char * -PkgRequireCore( - 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) +static int +PkgRequireCore(ClientData data[], Tcl_Interp *interp, int result) { - Interp *iPtr = (Interp *) interp; - Package *pkgPtr; - PkgAvail *availPtr, *bestPtr, *bestStablePtr; - char *availVersion, *bestVersion, *bestStableVersion; - /* Internal rep. of versions */ - int availStable, code, satisfies, pass; - char *script, *pkgVersionI; + const char *name = data[0]; + int reqc = PTR2INT(data[1]); + Tcl_Obj *const *reqv = data[2]; + int code = CheckAllRequirements(interp, reqc, reqv); + Require *reqPtr; + if (code != TCL_OK) { + return code; + } + reqPtr = ckalloc(sizeof(Require)); + Tcl_NRAddCallback(interp, PkgRequireCoreCleanup, reqPtr, NULL, NULL, NULL); + reqPtr->clientDataPtr = data[3]; + reqPtr->name = name; + reqPtr->pkgPtr = FindPackage(interp, name); + if (reqPtr->pkgPtr->version == NULL) { + Tcl_NRAddCallback(interp, SelectPackage, reqPtr, INT2PTR(reqc), (void *)reqv, PkgRequireCoreStep1); + } else { + Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + } + return TCL_OK; +} + +static int +PkgRequireCoreStep1(ClientData data[], Tcl_Interp *interp, int result) { Tcl_DString command; + char *script; + Require *reqPtr = data[0]; + int reqc = PTR2INT(data[1]); + Tcl_Obj **const reqv = data[2]; + const char *name = reqPtr->name /* Name of desired package. */; + if (reqPtr->pkgPtr->version == NULL) { + /* + * The package is not in the database. If there is a "package unknown" + * command, invoke it. + */ - if (TCL_OK != CheckAllRequirements(interp, reqc, reqv)) { - return NULL; + script = ((Interp *) interp)->packageUnknown; + if (script == NULL) { + Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + } else { + Tcl_DStringInit(&command); + Tcl_DStringAppend(&command, script, -1); + Tcl_DStringAppendElement(&command, name); + AddRequirementsToDString(&command, reqc, reqv); + + Tcl_NRAddCallback(interp, PkgRequireCoreStep2, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + Tcl_NREvalObj(interp, + Tcl_NewStringObj(Tcl_DStringValue(&command), Tcl_DStringLength(&command)), + TCL_EVAL_GLOBAL + ); + Tcl_DStringFree(&command); + } + return TCL_OK; + } else { + Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + } + return TCL_OK; +} + +static int +PkgRequireCoreStep2(ClientData data[], Tcl_Interp *interp, int result) { + Require *reqPtr = data[0]; + int reqc = PTR2INT(data[1]); + Tcl_Obj **const reqv = data[2]; + const char *name = reqPtr->name /* Name of desired package. */; + if ((result != TCL_OK) && (result != TCL_ERROR)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad return code: %d", result)); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); + result = TCL_ERROR; + } + if (result == TCL_ERROR) { + Tcl_AddErrorInfo(interp, + "\n (\"package unknown\" script)"); + return result; + } + Tcl_ResetResult(interp); + /* pkgPtr may now be invalid, so refresh it. */ + reqPtr->pkgPtr = FindPackage(interp, name); + Tcl_NRAddCallback(interp, SelectPackage, reqPtr, INT2PTR(reqc), (void *)reqv, PkgRequireCoreFinal); + return TCL_OK; +} + +static int +PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result) { + Require *reqPtr = data[0]; + int reqc = PTR2INT(data[1]), satisfies; + Tcl_Obj **const reqv = data[2]; + char *pkgVersionI; + void *clientDataPtr = reqPtr->clientDataPtr; + const char *name = reqPtr->name /* Name of desired package. */; + if (reqPtr->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, Tcl_GetString(reqPtr->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) { - Tcl_AppendResult(interp, "circular package dependency: " - "attempt to provide ", name, " ", - (char *) pkgPtr->clientData, " requires ", name, NULL); + if (!satisfies) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "version conflict for package \"%s\": have %s, need", + name, Tcl_GetString(reqPtr->pkgPtr->version))); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", + NULL); AddRequirementsToResult(interp, reqc, reqv); - return 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. - */ + if (clientDataPtr) { + const void **ptr = (const void **) clientDataPtr; - bestPtr = NULL; - bestStablePtr = NULL; - bestVersion = NULL; - bestStableVersion = NULL; + *ptr = reqPtr->pkgPtr->clientData; + } + Tcl_SetObjResult(interp, reqPtr->pkgPtr->version); + return TCL_OK; +} - 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. - */ +static int +PkgRequireCoreCleanup(ClientData data[], Tcl_Interp *interp, int result) { + ckfree(data[0]); + return result; +} - continue; - } - - /* 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 (bestPtr != NULL) { - int res = CompareVersions(availVersion, bestVersion, NULL); + +static int +SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { + PkgAvail *availPtr, *bestPtr, *bestStablePtr; + char *availVersion, *bestVersion, *bestStableVersion; + /* Internal rep. of versions */ + int availStable, satisfies; + Require *reqPtr = data[0]; + int reqc = PTR2INT(data[1]); + Tcl_Obj **const reqv = data[2]; + const char *name = reqPtr->name; + Package *pkgPtr = reqPtr->pkgPtr; + Interp *iPtr = (Interp *) interp; - /* - * Note: Used internal reps in the comparison! - */ + /* + * Check whether we're already attempting to load some version of this + * package (circular dependency detection). + */ - 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. */ + 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; + } - bestPtr = availPtr; - CheckVersionAndConvert(interp, bestPtr->version, &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. + */ + + bestPtr = NULL; + bestStablePtr = NULL; + bestVersion = NULL; + bestStableVersion = NULL; - if (!availStable) { + 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. + */ + + continue; + } + + /* 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 (bestPtr != NULL) { + int res = CompareVersions(availVersion, bestVersion, NULL); - if (bestStablePtr != NULL) { - int res = CompareVersions(availVersion, bestStableVersion, 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 ((iPtr->packagePrefer == PKG_PREFER_STABLE) - && (bestStablePtr != NULL)) { - bestPtr = bestStablePtr; - } + if (bestStablePtr != NULL) { + int res = CompareVersions(availVersion, bestStableVersion, NULL); - 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! */ - const char *versionToProvide = bestPtr->version; - script = bestPtr->script; - - pkgPtr->clientData = (ClientData) versionToProvide; - Tcl_Preserve((ClientData) script); - Tcl_Preserve((ClientData) versionToProvide); - code = Tcl_EvalEx(interp, script, -1, TCL_EVAL_GLOBAL); - Tcl_Release((ClientData) script); - - pkgPtr = FindPackage(interp, name); - if (code == TCL_OK) { - Tcl_ResetResult(interp); - if (pkgPtr->version == NULL) { - code = TCL_ERROR; - Tcl_AppendResult(interp, "attempt to provide package ", - name, " ", versionToProvide, - " failed: no version of package ", name, - " provided", 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_AppendResult(interp, - "attempt to provide package ", name, " ", - versionToProvide, " failed: package ", - name, " ", pkgPtr->version, - " provided instead", NULL); - } - } - } - } else if (code != TCL_ERROR) { - Tcl_Obj *codePtr = Tcl_NewIntObj(code); - - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "attempt to provide package ", name, - " ", versionToProvide, " failed: bad return code: ", - TclGetString(codePtr), 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((ClientData) 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 NULL; + ckfree(bestStableVersion); + bestStableVersion = NULL; + goto newstable; } - - break; + } else { + newstable: + /* We have found a stable version which is better than our max stable. */ + bestStablePtr = availPtr; + CheckVersionAndConvert(interp, bestStablePtr->version, &bestStableVersion, NULL); } - /* - * 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). - */ + ckfree(availVersion); + availVersion = NULL; + } /* end for */ - if (pass > 1) { - break; - } + /* + * Clean up memorized internal reps, if any. + */ - 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_Obj *codePtr = Tcl_NewIntObj(code); - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad return code: ", - TclGetString(codePtr), NULL); - Tcl_DecrRefCount(codePtr); - code = TCL_ERROR; - } - if (code == TCL_ERROR) { - Tcl_AddErrorInfo(interp, - "\n (\"package unknown\" script)"); - return NULL; - } - Tcl_ResetResult(interp); - } + if (bestVersion != NULL) { + ckfree(bestVersion); + bestVersion = NULL; } - if (pkgPtr->version == NULL) { - Tcl_AppendResult(interp, "can't find package ", name, NULL); - AddRequirementsToResult(interp, reqc, reqv); - return NULL; + 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) { - satisfies = 1; + if ((iPtr->packagePrefer == PKG_PREFER_STABLE) + && (bestStablePtr != NULL)) { + bestPtr = bestStablePtr; + } + + if (bestPtr == NULL) { + Tcl_NRAddCallback(interp, data[3], reqPtr, INT2PTR(reqc), (void *)reqv, NULL); } else { - CheckVersionAndConvert(interp, pkgPtr->version, &pkgVersionI, NULL); - satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv); + /* + * 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. + */ - ckfree(pkgVersionI); + char *versionToProvide = bestPtr->version; + + pkgPtr->clientData = versionToProvide; + Tcl_Preserve(versionToProvide); + reqPtr->versionToProvide = versionToProvide; + Tcl_NRAddCallback(interp, SelectPackageFinal, reqPtr, INT2PTR(reqc), (void *)reqv, data[3]); + Tcl_NREvalObj(interp, Tcl_NewStringObj(bestPtr->script, -1), TCL_EVAL_GLOBAL); + } + return TCL_OK; +} + +static int +SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) { + Require *reqPtr = data[0]; + int reqc = PTR2INT(data[1]); + Tcl_Obj **const reqv = data[2]; + const char *name = reqPtr->name; + char *versionToProvide = reqPtr->versionToProvide; + + reqPtr->pkgPtr = FindPackage(interp, name); + if (result == TCL_OK) { + Tcl_ResetResult(interp); + if (reqPtr->pkgPtr->version == NULL) { + result = 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 (TCL_OK != CheckVersionAndConvert(interp, + Tcl_GetString(reqPtr->pkgPtr->version), &pvi, NULL)) { + result = TCL_ERROR; + } else if (CheckVersionAndConvert(interp, + versionToProvide, &vi, NULL) != TCL_OK) { + ckfree(pvi); + result = TCL_ERROR; + } else { + int res = CompareVersions(pvi, vi, NULL); + + ckfree(pvi); + ckfree(vi); + if (res != 0) { + result = TCL_ERROR; + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "attempt to provide package %s %s failed:" + " package %s %s provided instead", + name, versionToProvide, + name, Tcl_GetString(reqPtr->pkgPtr->version))); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", + "WRONGPROVIDE", NULL); + } + } + } + } else if (result != TCL_ERROR) { + Tcl_Obj *codePtr = Tcl_NewIntObj(result); + + 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); + result = TCL_ERROR; + } + + if (result == TCL_ERROR) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"package ifneeded %s %s\" script)", + name, versionToProvide)); } + Tcl_Release(versionToProvide); + + if (result != 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 (satisfies) { - if (clientDataPtr) { - *clientDataPtr = pkgPtr->clientData; + if (reqPtr->pkgPtr->version != NULL) { + Tcl_DecrRefCount(reqPtr->pkgPtr->version); + reqPtr->pkgPtr->version = NULL; } - return pkgPtr->version; + reqPtr->pkgPtr->clientData = NULL; + return result; } - Tcl_AppendResult(interp, "version conflict for package \"", name, - "\": have ", pkgPtr->version, ", need", NULL); - AddRequirementsToResult(interp, reqc, reqv); - return NULL; + Tcl_NRAddCallback(interp, data[3], reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + return TCL_OK; } /* @@ -711,7 +806,7 @@ Tcl_PkgPresentEx( int exact, /* Non-zero means that only the particular * version given is acceptable. Zero means use * the latest compatible version. */ - ClientData *clientDataPtr) /* Used to return the client data for this + void *clientDataPtr) /* Used to return the client data for this * package. If it is NULL then the client data * is not returned. This is unchanged if this * call fails for any reason. */ @@ -742,10 +837,11 @@ Tcl_PkgPresentEx( } if (version != NULL) { - Tcl_AppendResult(interp, "package ", name, " ", version, - " is not present", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "package %s %s is not present", name, version)); } else { - Tcl_AppendResult(interp, "package ", name, " is not present", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "package %s is not present", name)); } Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PACKAGE", name, NULL); return NULL; @@ -767,16 +863,25 @@ Tcl_PkgPresentEx( * *---------------------------------------------------------------------- */ +int +Tcl_PackageObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + return Tcl_NRCallObjProc(interp, TclNRPackageObjCmd, NULL, objc, objv); +} /* ARGSUSED */ int -Tcl_PackageObjCmd( +TclNRPackageObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - static const char *pkgOptions[] = { + static const char *const pkgOptions[] = { "forget", "ifneeded", "names", "prefer", "present", "provide", "require", "unknown", "vcompare", "versions", "vsatisfies", NULL @@ -787,17 +892,19 @@ Tcl_PackageObjCmd( PKG_VSATISFIES }; Interp *iPtr = (Interp *) interp; - int optionIndex, exact, i, satisfies; + int optionIndex, exact, i, newobjc, satisfies; PkgAvail *availPtr, *prevPtr; Package *pkgPtr; Tcl_HashEntry *hPtr; Tcl_HashSearch search; Tcl_HashTable *tablePtr; const char *version; - char *argv2, *argv3, *argv4, *iva = NULL, *ivb = NULL; + const char *argv2, *argv3, *argv4; + char *iva = NULL, *ivb = NULL; + Tcl_Obj *objvListPtr, **newObjvPtr; if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); return TCL_ERROR; } @@ -807,7 +914,7 @@ Tcl_PackageObjCmd( } switch ((enum pkgOptions) optionIndex) { case PKG_FORGET: { - char *keyString; + const char *keyString; for (i = 2; i < objc; i++) { keyString = TclGetString(objv[i]); @@ -818,16 +925,16 @@ Tcl_PackageObjCmd( pkgPtr = Tcl_GetHashValue(hPtr); Tcl_DeleteHashEntry(hPtr); if (pkgPtr->version != NULL) { - ckfree(pkgPtr->version); + Tcl_DecrRefCount(pkgPtr->version); } while (pkgPtr->availPtr != NULL) { availPtr = pkgPtr->availPtr; pkgPtr->availPtr = availPtr->nextPtr; - Tcl_EventuallyFree((ClientData)availPtr->version, TCL_DYNAMIC); - Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); - ckfree((char *) availPtr); + Tcl_EventuallyFree(availPtr->version, TCL_DYNAMIC); + Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC); + ckfree(availPtr); } - ckfree((char *) pkgPtr); + ckfree(pkgPtr); } break; } @@ -870,10 +977,11 @@ Tcl_PackageObjCmd( if (res == 0){ if (objc == 4) { ckfree(argv3i); - Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE); + Tcl_SetObjResult(interp, + Tcl_NewStringObj(availPtr->script, -1)); return TCL_OK; } - Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); + Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC); break; } } @@ -883,7 +991,7 @@ Tcl_PackageObjCmd( return TCL_OK; } if (availPtr == NULL) { - availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail)); + availPtr = ckalloc(sizeof(PkgAvail)); DupBlock(availPtr->version, argv3, (unsigned) length + 1); if (prevPtr == NULL) { @@ -902,18 +1010,25 @@ Tcl_PackageObjCmd( if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; - } - tablePtr = &iPtr->packageTable; - for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; - hPtr = Tcl_NextHashEntry(&search)) { - pkgPtr = Tcl_GetHashValue(hPtr); - if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) { - Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr)); + } else { + Tcl_Obj *resultObj; + + resultObj = Tcl_NewObj(); + tablePtr = &iPtr->packageTable; + for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; + hPtr = Tcl_NextHashEntry(&search)) { + pkgPtr = Tcl_GetHashValue(hPtr); + if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) { + Tcl_ListObjAppendElement(NULL,resultObj, Tcl_NewStringObj( + Tcl_GetHashKey(tablePtr, hPtr), -1)); + } } + Tcl_SetObjResult(interp, resultObj); } break; case PKG_PRESENT: { const char *name; + if (objc < 3) { goto require; } @@ -968,7 +1083,7 @@ Tcl_PackageObjCmd( if (hPtr != NULL) { pkgPtr = Tcl_GetHashValue(hPtr); if (pkgPtr->version != NULL) { - Tcl_SetResult(interp, pkgPtr->version, TCL_VOLATILE); + Tcl_SetObjResult(interp, pkgPtr->version); } } return TCL_OK; @@ -983,7 +1098,7 @@ Tcl_PackageObjCmd( if (objc < 3) { requireSyntax: Tcl_WrongNumArgs(interp, 2, objv, - "?-exact? package ?requirement...?"); + "?-exact? package ?requirement ...?"); return TCL_ERROR; } @@ -992,7 +1107,6 @@ Tcl_PackageObjCmd( argv2 = TclGetString(objv[2]); if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { Tcl_Obj *ov; - int res; if (objc != 5) { goto requireSyntax; @@ -1012,17 +1126,38 @@ Tcl_PackageObjCmd( Tcl_AppendStringsToObj(ov, "-", version, NULL); version = NULL; argv3 = TclGetString(objv[3]); + Tcl_IncrRefCount(objv[3]); - Tcl_IncrRefCount(ov); - res = Tcl_PkgRequireProc(interp, argv3, 1, &ov, NULL); - TclDecrRefCount(ov); - return res; + objvListPtr = Tcl_NewListObj(0, NULL); + Tcl_IncrRefCount(objvListPtr); + Tcl_ListObjAppendElement(interp, objvListPtr, ov); + Tcl_ListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); + + Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[3], objvListPtr, NULL, NULL); + Tcl_NRAddCallback(interp, PkgRequireCore, (void *)argv3, INT2PTR(newobjc), newObjvPtr, NULL); + return TCL_OK; } else { + int i, newobjc = objc-3; + Tcl_Obj *const *newobjv = objv + 3; if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) { return TCL_ERROR; } + objvListPtr = Tcl_NewListObj(0, NULL); + Tcl_IncrRefCount(objvListPtr); + Tcl_IncrRefCount(objv[2]); + for (i = 0; i < newobjc; i++) { + + /* + * Tcl_Obj structures may have come from another interpreter, + * so duplicate them. + */ - return Tcl_PkgRequireProc(interp, argv2, objc-3, objv+3, NULL); + Tcl_ListObjAppendElement(interp, objvListPtr, Tcl_DuplicateObj(newobjv[i])); + } + Tcl_ListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); + Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[2], objvListPtr, NULL, NULL); + Tcl_NRAddCallback(interp, PkgRequireCore, (void *)argv2, INT2PTR(newobjc), newObjvPtr, NULL); + return TCL_OK; } break; case PKG_UNKNOWN: { @@ -1030,7 +1165,8 @@ Tcl_PackageObjCmd( if (objc == 2) { if (iPtr->packageUnknown != NULL) { - Tcl_SetResult(interp, iPtr->packageUnknown, TCL_VOLATILE); + Tcl_SetObjResult(interp, + Tcl_NewStringObj(iPtr->packageUnknown, -1)); } } else if (objc == 3) { if (iPtr->packageUnknown != NULL) { @@ -1049,7 +1185,7 @@ Tcl_PackageObjCmd( break; } case PKG_PREFER: { - static const char *pkgPreferOptions[] = { + static const char *const pkgPreferOptions[] = { "latest", "stable", NULL }; @@ -1118,23 +1254,27 @@ Tcl_PackageObjCmd( if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "package"); return TCL_ERROR; - } - argv2 = TclGetString(objv[2]); - hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); - if (hPtr != NULL) { - pkgPtr = Tcl_GetHashValue(hPtr); - for (availPtr = pkgPtr->availPtr; availPtr != NULL; - availPtr = availPtr->nextPtr) { - Tcl_AppendElement(interp, availPtr->version); + } else { + Tcl_Obj *resultObj = Tcl_NewObj(); + + argv2 = TclGetString(objv[2]); + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); + if (hPtr != NULL) { + pkgPtr = Tcl_GetHashValue(hPtr); + for (availPtr = pkgPtr->availPtr; availPtr != NULL; + availPtr = availPtr->nextPtr) { + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewStringObj(availPtr->version, -1)); + } } + Tcl_SetObjResult(interp, resultObj); } break; case PKG_VSATISFIES: { char *argv2i = NULL; if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, - "version requirement requirement..."); + Tcl_WrongNumArgs(interp, 2, objv, "version ?requirement ...?"); return TCL_ERROR; } @@ -1157,6 +1297,13 @@ Tcl_PackageObjCmd( } return TCL_OK; } + +static int +TclNRPackageObjCmdCleanup(ClientData data[], Tcl_Interp *interp, int result) { + TclDecrRefCount((Tcl_Obj *)data[0]); + TclDecrRefCount((Tcl_Obj *)data[1]); + return result; +} /* *---------------------------------------------------------------------- @@ -1188,7 +1335,7 @@ FindPackage( hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &isNew); if (isNew) { - pkgPtr = (Package *) ckalloc(sizeof(Package)); + pkgPtr = ckalloc(sizeof(Package)); pkgPtr->version = NULL; pkgPtr->availPtr = NULL; pkgPtr->clientData = NULL; @@ -1229,16 +1376,16 @@ TclFreePackageInfo( hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { pkgPtr = Tcl_GetHashValue(hPtr); if (pkgPtr->version != NULL) { - ckfree(pkgPtr->version); + Tcl_DecrRefCount(pkgPtr->version); } while (pkgPtr->availPtr != NULL) { availPtr = pkgPtr->availPtr; pkgPtr->availPtr = availPtr->nextPtr; - Tcl_EventuallyFree((ClientData)availPtr->version, TCL_DYNAMIC); - Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); - ckfree((char *) availPtr); + Tcl_EventuallyFree(availPtr->version, TCL_DYNAMIC); + Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC); + ckfree(availPtr); } - ckfree((char *) pkgPtr); + ckfree(pkgPtr); } Tcl_DeleteHashTable(&iPtr->packageTable); if (iPtr->packageUnknown != NULL) { @@ -1360,8 +1507,9 @@ CheckVersionAndConvert( error: ckfree(ibuf); - Tcl_AppendResult(interp, "expected version number but got \"", string, - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected version number but got \"%s\"", string)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSION", NULL); return TCL_ERROR; } @@ -1622,8 +1770,9 @@ CheckRequirement( * More dashes found after the first. This is wrong. */ - Tcl_AppendResult(interp, "expected versionMin-versionMax but got \"", - string, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected versionMin-versionMax but got \"%s\"", string)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSIONRANGE", NULL); return TCL_ERROR; } @@ -1674,19 +1823,17 @@ AddRequirementsToResult( Tcl_Obj *const reqv[]) /* 0 means to use the latest version * available. */ { - if (reqc > 0) { - int i; + Tcl_Obj *result = Tcl_GetObjResult(interp); + int i, length; - for (i = 0; i < reqc; i++) { - int length; - char *v = Tcl_GetStringFromObj(reqv[i], &length); + for (i = 0; i < reqc; i++) { + const 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); - } + if ((length & 0x1) && (v[length/2] == '-') + && (strncmp(v, v+((length+1)/2), length/2) == 0)) { + Tcl_AppendPrintfToObj(result, " exactly %s", v+((length+1)/2)); + } else { + Tcl_AppendPrintfToObj(result, " %s", v); } } } @@ -1715,15 +1862,15 @@ AddRequirementsToDString( Tcl_Obj *const reqv[]) /* 0 means to use the latest version * available. */ { - if (reqc > 0) { - int i; + int i; + if (reqc > 0) { for (i = 0; i < reqc; i++) { - Tcl_DStringAppend(dsPtr, " ", 1); - Tcl_DStringAppend(dsPtr, TclGetString(reqv[i]), -1); + TclDStringAppendLiteral(dsPtr, " "); + TclDStringAppendObj(dsPtr, reqv[i]); } } else { - Tcl_DStringAppend(dsPtr, " 0-", -1); + TclDStringAppendLiteral(dsPtr, " 0-"); } } |