diff options
Diffstat (limited to 'generic/tclPkg.c')
| -rw-r--r-- | generic/tclPkg.c | 703 |
1 files changed, 322 insertions, 381 deletions
diff --git a/generic/tclPkg.c b/generic/tclPkg.c index cecc634..df90cea 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -10,8 +10,6 @@ * 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.25 2006/11/15 20:08:45 dgp Exp $ - * * TIP #268. * Heavily rewritten to handle the extend version numbers, and extended * package requirements. @@ -44,11 +42,11 @@ 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. */ + * (malloc'ed). NULL means the package doesn't + * exist in this interpreter yet. */ PkgAvail *availPtr; /* First in list of all available versions of * this package. */ - ClientData clientData; /* Client data. */ + const void *clientData; /* Client data. */ } Package; /* @@ -56,24 +54,24 @@ typedef struct Package { */ static int CheckVersionAndConvert(Tcl_Interp *interp, - CONST char *string, char **internal, int *stable); + const char *string, char **internal, int *stable); static int CompareVersions(char *v1i, char *v2i, int *isMajorPtr); static int CheckRequirement(Tcl_Interp *interp, - CONST char *string); + const char *string); 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, - Tcl_Obj *CONST reqv[]); + Tcl_Obj *const reqv[]); +static int RequirementSatisfied(char *havei, const char *req); +static int SomeRequirementSatisfied(char *havei, int reqc, + Tcl_Obj *const reqv[]); static void AddRequirementsToResult(Tcl_Interp *interp, int reqc, - Tcl_Obj *CONST reqv[]); + 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); + 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[], + void *clientDataPtr); /* * Helper macros. @@ -108,12 +106,13 @@ static void VersionCleanupProc(ClientData clientData, *---------------------------------------------------------------------- */ +#undef Tcl_PkgProvide int Tcl_PkgProvide( Tcl_Interp *interp, /* Interpreter in which package is now * available. */ - CONST char *name, /* Name of package. */ - CONST char *version) /* Version string for package. */ + const char *name, /* Name of package. */ + const char *version) /* Version string for package. */ { return Tcl_PkgProvideEx(interp, name, version, NULL); } @@ -122,9 +121,9 @@ int Tcl_PkgProvideEx( Tcl_Interp *interp, /* Interpreter in which package is now * available. */ - CONST char *name, /* Name of package. */ - CONST char *version, /* Version string for package. */ - ClientData clientData) /* clientdata for this package (normally used + const char *name, /* Name of package. */ + const char *version, /* Version string for package. */ + const void *clientData) /* clientdata for this package (normally used * for C callback function table) */ { Package *pkgPtr; @@ -156,8 +155,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, pkgPtr->version, version)); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", NULL); return TCL_ERROR; } @@ -188,12 +189,13 @@ Tcl_PkgProvideEx( *---------------------------------------------------------------------- */ -CONST char * +#undef Tcl_PkgRequire +const char * Tcl_PkgRequire( Tcl_Interp *interp, /* Interpreter in which package is now * available. */ - CONST char *name, /* Name of desired package. */ - CONST char *version, /* Version string for desired version; NULL + const char *name, /* Name of desired package. */ + const char *version, /* Version string for desired version; NULL * means use the latest version available. */ int exact) /* Non-zero means that only the particular * version given is acceptable. Zero means use @@ -202,23 +204,23 @@ Tcl_PkgRequire( return Tcl_PkgRequireEx(interp, name, version, exact, NULL); } -CONST char * +const char * Tcl_PkgRequireEx( Tcl_Interp *interp, /* Interpreter in which package is now * available. */ - CONST char *name, /* Name of desired package. */ - CONST char *version, /* Version string for desired version; NULL + const char *name, /* Name of desired package. */ + const char *version, /* Version string for desired version; NULL * means use the latest version available. */ 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. */ { Tcl_Obj *ov; - int res; + const char *result = NULL; /* * If an attempt is being made to load this into a standalone executable @@ -285,81 +287,80 @@ 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; } - /* Translate between old and new API, and defer to the new function. */ + /* + * 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. */ + void *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. */ + 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 + Tcl_Obj *const reqv[], /* 0 means to use the latest version * available. */ - ClientData *clientDataPtr) + void *clientDataPtr) { Interp *iPtr = (Interp *) interp; Package *pkgPtr; PkgAvail *availPtr, *bestPtr, *bestStablePtr; char *availVersion, *bestVersion; /* Internal rep. of versions */ - int availStable; - char *script; - int code, satisfies, pass; + int availStable, code, satisfies, pass; + char *script, *pkgVersionI; Tcl_DString command; - char *pkgVersionI; + + if (TCL_OK != CheckAllRequirements(interp, reqc, reqv)) { + return NULL; + } /* * It can take up to three passes to find the package: one pass to run the @@ -374,17 +375,19 @@ Tcl_PkgRequireProc( break; } - /* - * Check whether we're already attempting to load some version - * of this package (circular dependency detection). + /* + * Check whether we're already attempting to load some version of this + * package (circular dependency detection). */ if (pkgPtr->clientData != NULL) { - Tcl_AppendResult(interp, "circular package dependency: ", - "attempt to provide ", name, " ", - (char *) pkgPtr->clientData, " requires ", name, 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); - return TCL_ERROR; + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", NULL); + return NULL; } /* @@ -403,7 +406,7 @@ Tcl_PkgRequireProc( if (CheckVersionAndConvert(interp, availPtr->version, &availVersion, &availStable) != TCL_OK) { /* - * The provided version number is has invalid syntax. This + * The provided version number has invalid syntax. This * should not happen. This should have been caught by the * 'package ifneeded' registering the package. */ @@ -414,7 +417,10 @@ Tcl_PkgRequireProc( if (bestPtr != NULL) { int res = CompareVersions(availVersion, bestVersion, NULL); - /* Note: Use internal reps! */ + /* + * Note: Use internal reps! + */ + if (res <= 0) { /* * The version of the package sought is not as good as the @@ -432,11 +438,9 @@ Tcl_PkgRequireProc( */ if (reqc > 0) { - /* - * Check satisfaction of requirements. - */ + /* Check satisfaction of requirements. */ - satisfies = AllRequirementsSatisfied(availVersion,reqc,reqv); + satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv); if (!satisfies) { ckfree(availVersion); availVersion = NULL; @@ -484,27 +488,28 @@ Tcl_PkgRequireProc( * will still exist when the script completes. */ - CONST char *versionToProvide = bestPtr->version; + char *versionToProvide = bestPtr->version; script = bestPtr->script; - pkgPtr->clientData = (ClientData) versionToProvide; - Tcl_Preserve((ClientData) script); - Tcl_Preserve((ClientData) versionToProvide); + pkgPtr->clientData = versionToProvide; + Tcl_Preserve(script); + Tcl_Preserve(versionToProvide); code = Tcl_EvalEx(interp, script, -1, TCL_EVAL_GLOBAL); - Tcl_Release((ClientData) script); + Tcl_Release(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); + 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; - int res; if (CheckVersionAndConvert(interp, pkgPtr->version, &pvi, NULL) != TCL_OK) { @@ -514,26 +519,30 @@ Tcl_PkgRequireProc( ckfree(pvi); code = TCL_ERROR; } else { - res = CompareVersions(pvi, vi, NULL); + 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); + 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_ResetResult(interp); - Tcl_AppendResult(interp, "attempt to provide package ", - name, " ", versionToProvide, " failed: ", - "bad return code: ", TclGetString(codePtr), NULL); + + 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; } @@ -543,7 +552,7 @@ Tcl_PkgRequireProc( "\n (\"package ifneeded %s %s\" script)", name, versionToProvide)); } - Tcl_Release((ClientData) versionToProvide); + Tcl_Release(versionToProvide); if (code != TCL_OK) { /* @@ -562,7 +571,7 @@ Tcl_PkgRequireProc( pkgPtr->version = NULL; } pkgPtr->clientData = NULL; - return TCL_ERROR; + return NULL; } break; @@ -590,26 +599,26 @@ Tcl_PkgRequireProc( 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); + 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 TCL_ERROR; + return NULL; } Tcl_ResetResult(interp); } } if (pkgPtr->version == NULL) { - Tcl_AppendResult(interp, "can't find package ", name, 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; + return NULL; } /* @@ -617,27 +626,29 @@ Tcl_PkgRequireProc( * provided version meets the current requirements. */ - if (reqc == 0) { - satisfies = 1; - } else { + if (reqc != 0) { CheckVersionAndConvert(interp, pkgPtr->version, &pkgVersionI, NULL); - satisfies = AllRequirementsSatisfied(pkgVersionI, reqc, reqv); + satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv); ckfree(pkgVersionI); - } - if (satisfies) { - if (clientDataPtr) { - *clientDataPtr = pkgPtr->clientData; + 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 NULL; } - Tcl_SetObjResult(interp, Tcl_NewStringObj(pkgPtr->version, -1)); - return TCL_OK; } - Tcl_AppendResult(interp, "version conflict for package \"", name, - "\": have ", pkgPtr->version, ", need", NULL); - AddRequirementsToResult(interp, reqc, reqv); - return TCL_ERROR; + if (clientDataPtr) { + const void **ptr = (const void **) clientDataPtr; + + *ptr = pkgPtr->clientData; + } + return pkgPtr->version; } /* @@ -661,12 +672,13 @@ Tcl_PkgRequireProc( *---------------------------------------------------------------------- */ -CONST char * +#undef Tcl_PkgPresent +const char * Tcl_PkgPresent( Tcl_Interp *interp, /* Interpreter in which package is now * available. */ - CONST char *name, /* Name of desired package. */ - CONST char *version, /* Version string for desired version; NULL + const char *name, /* Name of desired package. */ + const char *version, /* Version string for desired version; NULL * means use the latest version available. */ int exact) /* Non-zero means that only the particular * version given is acceptable. Zero means use @@ -675,17 +687,17 @@ Tcl_PkgPresent( return Tcl_PkgPresentEx(interp, name, version, exact, NULL); } -CONST char * +const char * Tcl_PkgPresentEx( Tcl_Interp *interp, /* Interpreter in which package is now * available. */ - CONST char *name, /* Name of desired package. */ - CONST char *version, /* Version string for desired version; NULL + const char *name, /* Name of desired package. */ + const char *version, /* Version string for desired version; NULL * means use the latest version available. */ 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. */ @@ -693,62 +705,36 @@ Tcl_PkgPresentEx( Interp *iPtr = (Interp *) interp; Tcl_HashEntry *hPtr; Package *pkgPtr; - int satisfies, result; hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name); if (hPtr) { pkgPtr = Tcl_GetHashValue(hPtr); if (pkgPtr->version != NULL) { - char *pvi, *vi; - int thisIsMajor; - /* * At this point we know that the package is present. Make sure - * that the provided version meets the current requirement. + * that the provided version meets the current requirement by + * calling Tcl_PkgRequireEx() to check for us. */ - if (version == NULL) { - if (clientDataPtr) { - *clientDataPtr = pkgPtr->clientData; - } - - return pkgPtr->version; - } - - if (CheckVersionAndConvert(interp, pkgPtr->version, &pvi, - NULL) != TCL_OK) { - return NULL; - } else if (CheckVersionAndConvert(interp, version, &vi, - NULL) != TCL_OK) { - ckfree(pvi); - return NULL; - } - - result = CompareVersions(pvi, vi, &thisIsMajor); - ckfree(pvi); - ckfree(vi); - - satisfies = (result == 0) || ((result == 1) && !thisIsMajor); + const char *foundVersion = Tcl_PkgRequireEx(interp, name, version, + exact, clientDataPtr); - if ((satisfies && !exact) || (result == 0)) { - if (clientDataPtr) { - *clientDataPtr = pkgPtr->clientData; - } - - return pkgPtr->version; + if (foundVersion == NULL) { + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PACKAGE", name, + NULL); } - Tcl_AppendResult(interp, "version conflict for package \"", name, - "\": have ", pkgPtr->version, ", need ", version, NULL); - return NULL; + return foundVersion; } } 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; } @@ -775,9 +761,9 @@ Tcl_PackageObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ + 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 @@ -794,11 +780,12 @@ Tcl_PackageObjCmd( Tcl_HashEntry *hPtr; Tcl_HashSearch search; Tcl_HashTable *tablePtr; - CONST char *version; - char *argv2, *argv3, *argv4, *iva = NULL, *ivb = NULL; + const char *version; + const char *argv2, *argv3, *argv4; + char *iva = NULL, *ivb = NULL; if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); return TCL_ERROR; } @@ -808,7 +795,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]); @@ -824,11 +811,11 @@ Tcl_PackageObjCmd( 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; } @@ -859,7 +846,6 @@ Tcl_PackageObjCmd( for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL; prevPtr = availPtr, availPtr = availPtr->nextPtr) { - if (CheckVersionAndConvert(interp, availPtr->version, &avi, NULL) != TCL_OK) { ckfree(argv3i); @@ -872,10 +858,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; } } @@ -885,7 +872,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) { @@ -904,49 +891,68 @@ 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: + case PKG_PRESENT: { + const char *name; + if (objc < 3) { - presentSyntax: - Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?"); - return TCL_ERROR; + goto require; } argv2 = TclGetString(objv[2]); if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { + if (objc != 5) { + goto requireSyntax; + } exact = 1; + name = TclGetString(objv[3]); } else { exact = 0; + name = argv2; + } + + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name); + if (hPtr != NULL) { + pkgPtr = Tcl_GetHashValue(hPtr); + if (pkgPtr->version != NULL) { + goto require; + } } + version = NULL; - if (objc == (4 + exact)) { - version = TclGetString(objv[3 + exact]); + if (exact) { + version = TclGetString(objv[4]); if (CheckVersionAndConvert(interp, version, NULL, NULL) != TCL_OK) { return TCL_ERROR; } - } else if ((objc != 3) || exact) { - goto presentSyntax; - } - if (exact) { - argv3 = TclGetString(objv[3]); - version = Tcl_PkgPresent(interp, argv3, version, exact); } else { - version = Tcl_PkgPresent(interp, argv2, version, exact); - } - if (version == NULL) { - return TCL_ERROR; + if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) { + return TCL_ERROR; + } + if ((objc > 3) && (CheckVersionAndConvert(interp, + TclGetString(objv[3]), NULL, NULL) == TCL_OK)) { + version = TclGetString(objv[3]); + } } - Tcl_SetObjResult(interp, Tcl_NewStringObj(version, -1)); + Tcl_PkgPresentEx(interp, name, version, exact, NULL); + return TCL_ERROR; break; + } case PKG_PROVIDE: if ((objc != 3) && (objc != 4)) { Tcl_WrongNumArgs(interp, 2, objv, "package ?version?"); @@ -958,7 +964,8 @@ Tcl_PackageObjCmd( if (hPtr != NULL) { pkgPtr = Tcl_GetHashValue(hPtr); if (pkgPtr->version != NULL) { - Tcl_SetResult(interp, pkgPtr->version, TCL_VOLATILE); + Tcl_SetObjResult(interp, + Tcl_NewStringObj(pkgPtr->version, -1)); } } return TCL_OK; @@ -967,12 +974,13 @@ Tcl_PackageObjCmd( if (CheckVersionAndConvert(interp, argv3, NULL, NULL) != TCL_OK) { return TCL_ERROR; } - return Tcl_PkgProvide(interp, argv2, argv3); + return Tcl_PkgProvideEx(interp, argv2, argv3, NULL); case PKG_REQUIRE: + require: if (objc < 3) { requireSyntax: Tcl_WrongNumArgs(interp, 2, objv, - "?-exact? package ?requirement...?"); + "?-exact? package ?requirement ...?"); return TCL_ERROR; } @@ -997,7 +1005,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]); @@ -1018,7 +1027,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) { @@ -1037,7 +1047,7 @@ Tcl_PackageObjCmd( break; } case PKG_PREFER: { - static CONST char *pkgPreferOptions[] = { + static const char *const pkgPreferOptions[] = { "latest", "stable", NULL }; @@ -1106,23 +1116,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; } @@ -1134,7 +1148,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)); @@ -1167,7 +1181,7 @@ Tcl_PackageObjCmd( static Package * FindPackage( Tcl_Interp *interp, /* Interpreter to use for package lookup. */ - CONST char *name) /* Name of package to fine. */ + const char *name) /* Name of package to fine. */ { Interp *iPtr = (Interp *) interp; Tcl_HashEntry *hPtr; @@ -1176,7 +1190,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; @@ -1222,11 +1236,11 @@ TclFreePackageInfo( 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) { @@ -1257,13 +1271,13 @@ TclFreePackageInfo( static int CheckVersionAndConvert( Tcl_Interp *interp, /* Used for error reporting. */ - CONST char *string, /* Supposedly a version number, which is + const char *string, /* Supposedly a version number, which is * groups of decimal digits separated by * dots. */ char **internal, /* Internal normalized representation */ int *stable) /* Flag: Version is (un)stable. */ { - CONST char *p = string; + const char *p = string; char prevChar; int hasunstable = 0; /* @@ -1348,8 +1362,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; } @@ -1511,7 +1526,10 @@ CompareVersions( if (*s1 != 0) { s1++; } else if (*s2 == 0) { - /* s1, s2 both at the end => identical */ + /* + * s1, s2 both at the end => identical + */ + res = 0; break; } @@ -1550,7 +1568,7 @@ static int CheckAllRequirements( Tcl_Interp *interp, int reqc, /* Requirements to check. */ - Tcl_Obj *CONST reqv[]) + Tcl_Obj *const reqv[]) { int i; @@ -1583,7 +1601,7 @@ CheckAllRequirements( static int CheckRequirement( Tcl_Interp *interp, /* Used for error reporting. */ - CONST char *string) /* Supposedly a requirement. */ + const char *string) /* Supposedly a requirement. */ { /* * Syntax of requirement = version @@ -1596,7 +1614,7 @@ CheckRequirement( dash = strchr(string, '-'); if (dash == NULL) { /* - * no dash found, has to be a simple version. + * No dash found, has to be a simple version. */ return CheckVersionAndConvert(interp, string, NULL, NULL); @@ -1607,15 +1625,17 @@ 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; } /* * Exactly one dash is present. Copy the string, split at the location of * dash and check that both parts are versions. Note that the max part can - * be empty. + * be empty. Also note that the string allocated with strdup() must be + * freed with free() and not ckfree(). */ DupString(buf, string); @@ -1655,14 +1675,20 @@ AddRequirementsToResult( Tcl_Interp *interp, int reqc, /* Requirements constraining the desired * version. */ - Tcl_Obj *CONST reqv[]) /* 0 means to use the latest version + 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++) { - Tcl_AppendResult(interp, " ", TclGetString(reqv[i]), NULL); + 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_AppendPrintfToObj(result, " exactly %s", v+((length+1)/2)); + } else { + Tcl_AppendPrintfToObj(result, " %s", v); } } } @@ -1688,23 +1714,25 @@ AddRequirementsToDString( Tcl_DString *dsPtr, int reqc, /* Requirements constraining the desired * version. */ - Tcl_Obj *CONST reqv[]) /* 0 means to use the latest version + 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 { + TclDStringAppendLiteral(dsPtr, " 0-"); } } /* *---------------------------------------------------------------------- * - * AllRequirementSatisfied -- + * SomeRequirementSatisfied -- * * This function checks to see whether a version satisfies at least one * of a set of requirements. @@ -1721,12 +1749,12 @@ AddRequirementsToDString( */ static int -AllRequirementsSatisfied( +SomeRequirementSatisfied( char *availVersionI, /* Candidate version to check against the * requirements. */ int reqc, /* Requirements constraining the desired * version. */ - Tcl_Obj *CONST reqv[]) /* 0 means to use the latest version + Tcl_Obj *const reqv[]) /* 0 means to use the latest version * available. */ { int i; @@ -1761,7 +1789,7 @@ static int RequirementSatisfied( char *havei, /* Version string, of candidate package we * have. */ - CONST char *req) /* Requirement string the candidate has to + const char *req) /* Requirement string the candidate has to * satisfy. */ { /* @@ -1843,14 +1871,15 @@ RequirementSatisfied( /* *---------------------------------------------------------------------- * - * ExactRequirement -- + * Tcl_PkgInitStubsCheck -- * - * 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. + * This is a replacement routine for Tcl_InitStubs() that is called + * from code where -DUSE_TCL_STUBS has not been enabled. * * Results: - * A Tcl_Obj containing the version range as string. + * Returns the version of a conforming stubs table, or NULL, if + * the table version doesn't satisfy the requested requirements, + * according to historical practice. * * Side effects: * None. @@ -1858,121 +1887,33 @@ RequirementSatisfied( *---------------------------------------------------------------------- */ -static Tcl_Obj * -ExactRequirement( - CONST char *version) +const char * +Tcl_PkgInitStubsCheck( + Tcl_Interp *interp, + const char * version, + int exact) { - /* - * 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); + const char *actualVersion = Tcl_PkgPresent(interp, "Tcl", version, 0); - Tcl_AppendStringsToObj(objPtr, "-", NULL); + if (exact && actualVersion) { + const char *p = version; + int count = 0; - /* - * 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); + while (*p) { + count += !isdigit(UCHAR(*p++)); + } + if (count == 1) { + if (0 != strncmp(version, actualVersion, strlen(version))) { + /* Construct error message */ + Tcl_PkgPresent(interp, "Tcl", version, 1); + return NULL; + } } else { - Tcl_AppendStringsToObj(objPtr, ".", NULL); + return Tcl_PkgPresent(interp, "Tcl", version, 1); } } - - /* - * 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); - } + return actualVersion; } - /* * Local Variables: * mode: c |