diff options
Diffstat (limited to 'generic/tclPkg.c')
| -rw-r--r-- | generic/tclPkg.c | 1341 |
1 files changed, 701 insertions, 640 deletions
diff --git a/generic/tclPkg.c b/generic/tclPkg.c index ea10e18..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.21 2006/10/16 17:43:20 dgp Exp $ - * * TIP #268. * Heavily rewritten to handle the extend version numbers, and extended * package requirements. @@ -44,36 +42,48 @@ 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; /* * Prototypes for functions defined in this file: */ -static int CheckVersionAndConvert(Tcl_Interp *interp, CONST char *string, - char** internal, int* stable); - +static int CheckVersionAndConvert(Tcl_Interp *interp, + 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); -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[]); -static void AddRequirementsToResult(Tcl_Interp* interp, - int reqc, 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 *isMajorPtr); +static int CheckRequirement(Tcl_Interp *interp, + 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 SomeRequirementSatisfied(char *havei, int reqc, + Tcl_Obj *const reqv[]); +static void AddRequirementsToResult(Tcl_Interp *interp, int reqc, + 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 const char * PkgRequireCore(Tcl_Interp *interp, const char *name, + int reqc, Tcl_Obj *const reqv[], + void *clientDataPtr); + +/* + * Helper macros. + */ + +#define DupBlock(v,s,len) \ + ((v) = ckalloc(len), memcpy((v),(s),(len))) +#define DupString(v,s) \ + do { \ + unsigned local__len = (unsigned) (strlen(s) + 1); \ + DupBlock((v),(s),local__len); \ + } while (0) /* *---------------------------------------------------------------------- @@ -96,48 +106,48 @@ 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, (ClientData) NULL); + return Tcl_PkgProvideEx(interp, name, version, NULL); } 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; - char* pvi; - char* vi; + char *pvi, *vi; int res; pkgPtr = FindPackage(interp, name); if (pkgPtr->version == NULL) { - pkgPtr->version = ckalloc((unsigned) (strlen(version) + 1)); - strcpy(pkgPtr->version, version); + DupString(pkgPtr->version, version); pkgPtr->clientData = clientData; return TCL_OK; } - if (CheckVersionAndConvert (interp, pkgPtr->version, &pvi, NULL) != TCL_OK) { + if (CheckVersionAndConvert(interp, pkgPtr->version, &pvi, + NULL) != TCL_OK) { return TCL_ERROR; - } else if (CheckVersionAndConvert (interp, version, &vi, NULL) != TCL_OK) { - Tcl_Free (pvi); + } else if (CheckVersionAndConvert(interp, version, &vi, NULL) != TCL_OK) { + ckfree(pvi); return TCL_ERROR; } res = CompareVersions(pvi, vi, NULL); - Tcl_Free (pvi); - Tcl_Free (vi); + ckfree(pvi); + ckfree(vi); if (res == 0) { if (clientData != NULL) { @@ -145,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; } @@ -177,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 @@ -191,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 @@ -274,78 +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); - Tcl_DecrRefCount (ov); + Tcl_IncrRefCount(ov); + 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) { - Tcl_DecrRefCount (ov); + if (result == NULL) { + return TCL_ERROR; } - - ov = Tcl_GetObjResult (interp); - Tcl_IncrRefCount (ov); - Tcl_SetAssocData(interp, "tcl/Tcl_PkgRequireEx", VersionCleanupProc, - (ClientData) ov); - Tcl_ResetResult (interp); - - return Tcl_GetString (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. */ - int reqc, /* Requirements constraining the desired version. */ - Tcl_Obj *CONST reqv[], /* 0 means to use the latest version available. */ - ClientData *clientDataPtr) + 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) { 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; + PkgAvail *availPtr, *bestPtr, *bestStablePtr; + char *availVersion, *bestVersion; + /* Internal rep. of versions */ + 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 @@ -354,42 +369,44 @@ Tcl_PkgRequireProc( * the "package ifneeded" script. */ - for (pass = 1; ; pass++) { + for (pass=1 ;; pass++) { pkgPtr = FindPackage(interp, name); if (pkgPtr->version != NULL) { 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); - AddRequirementsToResult (interp, reqc, reqv); - return TCL_ERROR; + 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 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. + * 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; + bestPtr = NULL; + bestStablePtr = NULL; + bestVersion = NULL; - for (availPtr = pkgPtr->availPtr; - availPtr != NULL; - availPtr = availPtr->nextPtr) { - if (CheckVersionAndConvert (interp, availPtr->version, - &availVersion, &availStable) != TCL_OK) { - /* The provided version number is has invalid syntax. This + 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. */ @@ -398,24 +415,34 @@ Tcl_PkgRequireProc( } if (bestPtr != NULL) { - int res = CompareVersions (availVersion, bestVersion, NULL); - /* Note: Use internal reps! */ + int res = CompareVersions(availVersion, bestVersion, NULL); + + /* + * Note: Use internal reps! + */ + if (res <= 0) { - /* The version of the package sought is not as good as the - * currently selected version. Ignore it. */ - Tcl_Free (availVersion); + /* + * The version of the package sought is not as good as the + * currently selected version. Ignore it. + */ + + ckfree(availVersion); availVersion = NULL; continue; } } - /* We have found a version which is better than our max. */ + /* + * We have found a version which is better than our max. + */ if (reqc > 0) { - /* Check satisfaction of requirements */ - satisfies = AllRequirementsSatisfied (availVersion, reqc, reqv); + /* Check satisfaction of requirements. */ + + satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv); if (!satisfies) { - Tcl_Free (availVersion); + ckfree(availVersion); availVersion = NULL; continue; } @@ -423,10 +450,13 @@ Tcl_PkgRequireProc( bestPtr = availPtr; - if (bestVersion != NULL) Tcl_Free (bestVersion); + if (bestVersion != NULL) { + ckfree(bestVersion); + } bestVersion = availVersion; - /* If this new best version is stable then it also has to be + /* + * If this new best version is stable then it also has to be * better than the max stable version found so far. */ @@ -436,15 +466,17 @@ Tcl_PkgRequireProc( } if (bestVersion != NULL) { - Tcl_Free (bestVersion); + ckfree(bestVersion); } - /* Now choose a version among the two best. For 'latest' we simply + /* + * 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)) { + if ((iPtr->packagePrefer == PKG_PREFER_STABLE) + && (bestStablePtr != NULL)) { bestPtr = bestStablePtr; } @@ -455,83 +487,91 @@ Tcl_PkgRequireProc( * script itself from deletion and (b) don't assume that bestPtr * 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; - char* vi; - int res; + char *pvi, *vi; - if (CheckVersionAndConvert (interp, pkgPtr->version, &pvi, NULL) != TCL_OK) { + if (CheckVersionAndConvert(interp, pkgPtr->version, &pvi, + NULL) != TCL_OK) { code = TCL_ERROR; - } else if (CheckVersionAndConvert (interp, versionToProvide, &vi, NULL) != TCL_OK) { - Tcl_Free (pvi); + } else if (CheckVersionAndConvert(interp, + versionToProvide, &vi, NULL) != TCL_OK) { + ckfree(pvi); code = TCL_ERROR; } else { - res = CompareVersions(pvi, vi, NULL); - Tcl_Free (pvi); - Tcl_Free (vi); + 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: ", Tcl_GetString(codePtr), NULL); - Tcl_DecrRefCount(codePtr); + + 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) { - TclFormatToErrorInfo(interp, + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (\"package ifneeded %s %s\" script)", - name, versionToProvide); + name, versionToProvide)); } - Tcl_Release((ClientData) versionToProvide); + Tcl_Release(versionToProvide); 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. + * 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 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 TCL_ERROR; + return NULL; } break; @@ -559,25 +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: ", - Tcl_GetString(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; + Tcl_AddErrorInfo(interp, + "\n (\"package unknown\" script)"); + 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; } /* @@ -585,27 +626,29 @@ Tcl_PkgRequireProc( * provided version meets the current requirements. */ - if (reqc == 0) { - satisfies = 1; - } else { - CheckVersionAndConvert (interp, pkgPtr->version, &pkgVersionI, NULL); - satisfies = AllRequirementsSatisfied (pkgVersionI, reqc, reqv); + if (reqc != 0) { + CheckVersionAndConvert(interp, pkgPtr->version, &pkgVersionI, NULL); + satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv); - Tcl_Free (pkgVersionI); - } + 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; } /* @@ -629,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 @@ -643,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. */ @@ -661,61 +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 = (Package *) Tcl_GetHashValue(hPtr); + pkgPtr = Tcl_GetHashValue(hPtr); if (pkgPtr->version != NULL) { - char* pvi; - char* 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) { - Tcl_Free (pvi); - return NULL; - } - - result = CompareVersions(pvi, vi, &thisIsMajor); - Tcl_Free (pvi); - Tcl_Free (vi); + const char *foundVersion = Tcl_PkgRequireEx(interp, name, version, + exact, clientDataPtr); - satisfies = (result == 0) || ((result == 1) && !thisIsMajor); - - 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; } @@ -742,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 @@ -761,13 +780,12 @@ Tcl_PackageObjCmd( Tcl_HashEntry *hPtr; Tcl_HashSearch search; Tcl_HashTable *tablePtr; - CONST char *version; - char *argv2, *argv3, *argv4; - char* iva = NULL; - char* 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; } @@ -777,15 +795,15 @@ Tcl_PackageObjCmd( } switch ((enum pkgOptions) optionIndex) { case PKG_FORGET: { - char *keyString; + const char *keyString; for (i = 2; i < objc; i++) { - keyString = Tcl_GetString(objv[i]); + keyString = TclGetString(objv[i]); hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString); if (hPtr == NULL) { continue; } - pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + pkgPtr = Tcl_GetHashValue(hPtr); Tcl_DeleteHashEntry(hPtr); if (pkgPtr->version != NULL) { ckfree(pkgPtr->version); @@ -793,72 +811,69 @@ 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; } case PKG_IFNEEDED: { - int length; - char* argv3i; - char* avi; - int res; + int length, res; + char *argv3i, *avi; if ((objc != 4) && (objc != 5)) { Tcl_WrongNumArgs(interp, 2, objv, "package version ?script?"); return TCL_ERROR; } - argv3 = Tcl_GetString(objv[3]); + argv3 = TclGetString(objv[3]); if (CheckVersionAndConvert(interp, argv3, &argv3i, NULL) != TCL_OK) { return TCL_ERROR; } - argv2 = Tcl_GetString(objv[2]); + argv2 = TclGetString(objv[2]); if (objc == 4) { hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); if (hPtr == NULL) { - Tcl_Free (argv3i); + ckfree(argv3i); return TCL_OK; } - pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + pkgPtr = Tcl_GetHashValue(hPtr); } else { pkgPtr = FindPackage(interp, argv2); } argv3 = Tcl_GetStringFromObj(objv[3], &length); - for (availPtr = pkgPtr->availPtr, prevPtr = NULL; - availPtr != NULL; - prevPtr = availPtr, availPtr = availPtr->nextPtr) { - - if (CheckVersionAndConvert (interp, availPtr->version, &avi, NULL) != TCL_OK) { - Tcl_Free (argv3i); + for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL; + prevPtr = availPtr, availPtr = availPtr->nextPtr) { + if (CheckVersionAndConvert(interp, availPtr->version, &avi, + NULL) != TCL_OK) { + ckfree(argv3i); return TCL_ERROR; } res = CompareVersions(avi, argv3i, NULL); - Tcl_Free (avi); + ckfree(avi); if (res == 0){ if (objc == 4) { - Tcl_Free (argv3i); - Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE); + ckfree(argv3i); + 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; } } - Tcl_Free (argv3i); + ckfree(argv3i); if (objc == 4) { return TCL_OK; } if (availPtr == NULL) { - availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail)); - availPtr->version = ckalloc((unsigned) (length + 1)); - strcpy(availPtr->version, argv3); + availPtr = ckalloc(sizeof(PkgAvail)); + DupBlock(availPtr->version, argv3, (unsigned) length + 1); if (prevPtr == NULL) { availPtr->nextPtr = pkgPtr->availPtr; @@ -869,112 +884,138 @@ Tcl_PackageObjCmd( } } argv4 = Tcl_GetStringFromObj(objv[4], &length); - availPtr->script = ckalloc((unsigned) (length + 1)); - strcpy(availPtr->script, argv4); + DupBlock(availPtr->script, argv4, (unsigned) length + 1); break; } case PKG_NAMES: 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 = (Package *) 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 = Tcl_GetString(objv[2]); + 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; } - version = NULL; - if (objc == (4 + exact)) { - version = Tcl_GetString(objv[3 + exact]); - if (CheckVersionAndConvert(interp, version, NULL, NULL) != TCL_OK) { - return TCL_ERROR; + + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name); + if (hPtr != NULL) { + pkgPtr = Tcl_GetHashValue(hPtr); + if (pkgPtr->version != NULL) { + goto require; } - } else if ((objc != 3) || exact) { - goto presentSyntax; } + + version = NULL; if (exact) { - argv3 = Tcl_GetString(objv[3]); - version = Tcl_PkgPresent(interp, argv3, version, exact); + version = TclGetString(objv[4]); + if (CheckVersionAndConvert(interp, version, NULL, + NULL) != TCL_OK) { + return TCL_ERROR; + } } 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?"); return TCL_ERROR; } - argv2 = Tcl_GetString(objv[2]); + argv2 = TclGetString(objv[2]); if (objc == 3) { hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); if (hPtr != NULL) { - pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + 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; } - argv3 = Tcl_GetString(objv[3]); + argv3 = TclGetString(objv[3]); 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...?"); + Tcl_WrongNumArgs(interp, 2, objv, + "?-exact? package ?requirement ...?"); return TCL_ERROR; } version = NULL; - argv2 = Tcl_GetString(objv[2]); + argv2 = TclGetString(objv[2]); if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { - Tcl_Obj* ov; + Tcl_Obj *ov; int res; if (objc != 5) { goto requireSyntax; } - version = Tcl_GetString(objv[4]); - if (CheckVersionAndConvert(interp, version, NULL, NULL) != TCL_OK) { + version = TclGetString(objv[4]); + if (CheckVersionAndConvert(interp, version, NULL, + NULL) != TCL_OK) { return TCL_ERROR; } - /* Create a new-style requirement for the exact version. */ + /* + * 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 = Tcl_GetString(objv[3]); + argv3 = TclGetString(objv[3]); - Tcl_IncrRefCount (ov); + Tcl_IncrRefCount(ov); res = Tcl_PkgRequireProc(interp, argv3, 1, &ov, NULL); - Tcl_DecrRefCount (ov); + TclDecrRefCount(ov); return res; } else { - if (CheckAllRequirements (interp, objc-3, objv+3) != TCL_OK) { + if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) { return TCL_ERROR; } @@ -986,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) { @@ -996,8 +1038,7 @@ Tcl_PackageObjCmd( if (argv2[0] == 0) { iPtr->packageUnknown = NULL; } else { - iPtr->packageUnknown = (char *) ckalloc((unsigned) (length+1)); - strcpy(iPtr->packageUnknown, argv2); + DupBlock(iPtr->packageUnknown, argv2, (unsigned) length+1); } } else { Tcl_WrongNumArgs(interp, 2, objv, "?command?"); @@ -1006,31 +1047,40 @@ Tcl_PackageObjCmd( break; } case PKG_PREFER: { - /* See tclInt.h for the enum, just before Interp */ - static CONST char *pkgPreferOptions[] = { + static const char *const pkgPreferOptions[] = { "latest", "stable", NULL }; + /* + * See tclInt.h for the enum, just before Interp. + */ + if (objc > 3) { Tcl_WrongNumArgs(interp, 2, objv, "?latest|stable?"); return TCL_ERROR; - } + } else if (objc == 3) { + /* + * Seting the value. + */ - if (objc == 3) { - /* Set value. */ + int newPref; - int new; - if (Tcl_GetIndexFromObj(interp, objv[2], pkgPreferOptions, "preference", 0, - &new) != TCL_OK) { + if (Tcl_GetIndexFromObj(interp, objv[2], pkgPreferOptions, + "preference", 0, &newPref) != TCL_OK) { return TCL_ERROR; } - if (new < iPtr->packagePrefer) { - iPtr->packagePrefer = new; + if (newPref < iPtr->packagePrefer) { + iPtr->packagePrefer = newPref; } } - /* Always return current value. */ - Tcl_SetObjResult(interp, Tcl_NewStringObj (pkgPreferOptions [iPtr->packagePrefer], -1)); + + /* + * Always return current value. + */ + + Tcl_SetObjResult(interp, + Tcl_NewStringObj(pkgPreferOptions[iPtr->packagePrefer], -1)); break; } case PKG_VCOMPARE: @@ -1038,53 +1088,68 @@ Tcl_PackageObjCmd( Tcl_WrongNumArgs(interp, 2, objv, "version1 version2"); return TCL_ERROR; } - argv3 = Tcl_GetString(objv[3]); - argv2 = Tcl_GetString(objv[2]); - if ((CheckVersionAndConvert (interp, argv2, &iva, NULL) != TCL_OK) || - (CheckVersionAndConvert (interp, argv3, &ivb, NULL) != TCL_OK)) { - if (iva != NULL) { Tcl_Free (iva); } - /* ivb cannot be set in this branch */ + argv3 = TclGetString(objv[3]); + argv2 = TclGetString(objv[2]); + if (CheckVersionAndConvert(interp, argv2, &iva, NULL) != TCL_OK || + CheckVersionAndConvert(interp, argv3, &ivb, NULL) != TCL_OK) { + if (iva != NULL) { + ckfree(iva); + } + + /* + * ivb cannot be set in this branch. + */ + return TCL_ERROR; } - /* Comparison is done on the internal representation */ - Tcl_SetObjResult(interp,Tcl_NewIntObj(CompareVersions(iva, ivb, NULL))); - Tcl_Free (iva); - Tcl_Free (ivb); + /* + * Comparison is done on the internal representation. + */ + + Tcl_SetObjResult(interp, + Tcl_NewIntObj(CompareVersions(iva, ivb, NULL))); + ckfree(iva); + ckfree(ivb); break; case PKG_VERSIONS: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "package"); return TCL_ERROR; - } - argv2 = Tcl_GetString(objv[2]); - hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); - if (hPtr != NULL) { - pkgPtr = (Package *) 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; + char *argv2i = NULL; if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, "version requirement requirement..."); + Tcl_WrongNumArgs(interp, 2, objv, "version ?requirement ...?"); return TCL_ERROR; } - argv2 = Tcl_GetString(objv[2]); - if ((CheckVersionAndConvert(interp, argv2, &argv2i, NULL) != TCL_OK)) { + argv2 = TclGetString(objv[2]); + if (CheckVersionAndConvert(interp, argv2, &argv2i, NULL) != TCL_OK) { return TCL_ERROR; - } else if (CheckAllRequirements (interp, objc-3, objv+3) != TCL_OK) { - Tcl_Free (argv2i); + } else if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) { + ckfree(argv2i); return TCL_ERROR; } - satisfies = AllRequirementsSatisfied (argv2i, objc-3, objv+3); - Tcl_Free (argv2i); + satisfies = SomeRequirementSatisfied(argv2i, objc-3, objv+3); + ckfree(argv2i); Tcl_SetObjResult(interp, Tcl_NewBooleanObj(satisfies)); break; @@ -1116,22 +1181,22 @@ 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; - int new; + int isNew; Package *pkgPtr; - hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &new); - if (new) { - pkgPtr = (Package *) ckalloc(sizeof(Package)); + hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &isNew); + if (isNew) { + pkgPtr = ckalloc(sizeof(Package)); pkgPtr->version = NULL; pkgPtr->availPtr = NULL; pkgPtr->clientData = NULL; Tcl_SetHashValue(hPtr, pkgPtr); } else { - pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + pkgPtr = Tcl_GetHashValue(hPtr); } return pkgPtr; } @@ -1164,18 +1229,18 @@ TclFreePackageInfo( for (hPtr = Tcl_FirstHashEntry(&iPtr->packageTable, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + pkgPtr = Tcl_GetHashValue(hPtr); if (pkgPtr->version != NULL) { ckfree(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) { @@ -1188,9 +1253,9 @@ TclFreePackageInfo( * * CheckVersionAndConvert -- * - * This function checks to see whether a version number has valid - * syntax. It also generates a semi-internal representation (string - * rep of a list of numbers). + * This function checks to see whether a version number has valid syntax. + * It also generates a semi-internal representation (string rep of a list + * of numbers). * * Results: * If string is a properly formed version number the TCL_OK is returned. @@ -1205,27 +1270,29 @@ TclFreePackageInfo( static int CheckVersionAndConvert( - Tcl_Interp *interp, /* Used for error reporting. */ - 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. */ + Tcl_Interp *interp, /* Used for error reporting. */ + 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; - /* 4* assuming that each char is a separator (a,b become ' -x '). + /* + * 4* assuming that each char is a separator (a,b become ' -x '). * 4+ to have spce for an additional -2 at the end */ - char* ibuf = ckalloc (4+4*strlen(string)); - char* ip = ibuf; + char *ibuf = ckalloc(4 + 4*strlen(string)); + char *ip = ibuf; - /* Basic rules + /* + * Basic rules * (1) First character has to be a digit. * (2) All other characters have to be a digit or '.' * (3) Two '.'s may not follow each other. - + * * TIP 268, Modified rules * (1) s.a. * (2) All other characters have to be a digit, 'a', 'b', or '.' @@ -1234,43 +1301,58 @@ CheckVersionAndConvert( * (5) Neither 'a', nor 'b' may occur before or after a '.' */ - if (!isdigit(UCHAR(*p))) { /* INTL: digit */ + if (!isdigit(UCHAR(*p))) { /* INTL: digit */ goto error; } *ip++ = *p; for (prevChar = *p, p++; *p != 0; p++) { - if ( - (!isdigit(UCHAR(*p))) && - (((*p != '.') && (*p != 'a') && (*p != 'b')) || - ((hasunstable && ((*p == 'a') || (*p == 'b'))) || - (((prevChar == 'a') || (prevChar == 'b') || (prevChar == '.')) && (*p == '.')) || - (((*p == 'a') || (*p == 'b') || (*p == '.')) && (prevChar == '.')))) - ) { - /* INTL: digit */ + if (!isdigit(UCHAR(*p)) && /* INTL: digit */ + ((*p!='.' && *p!='a' && *p!='b') || + ((hasunstable && (*p=='a' || *p=='b')) || + ((prevChar=='a' || prevChar=='b' || prevChar=='.') + && (*p=='.')) || + ((*p=='a' || *p=='b' || *p=='.') && prevChar=='.')))) { goto error; } - if ((*p == 'a') || (*p == 'b')) { hasunstable = 1 ; } + if (*p == 'a' || *p == 'b') { + hasunstable = 1; + } - /* Translation to the internal rep. Regular version chars are copied + /* + * Translation to the internal rep. Regular version chars are copied * as is. The separators are translated to numerics. The new separator - * for all parts is space. */ + * for all parts is space. + */ - if (*p == '.') { *ip++ = ' '; *ip++ = '0'; *ip++ = ' '; } - else if (*p == 'a') { *ip++ = ' '; *ip++ = '-'; *ip++ = '2'; *ip++ = ' '; } - else if (*p == 'b') { *ip++ = ' '; *ip++ = '-'; *ip++ = '1'; *ip++ = ' '; } - else { *ip++ = *p; } + if (*p == '.') { + *ip++ = ' '; + *ip++ = '0'; + *ip++ = ' '; + } else if (*p == 'a') { + *ip++ = ' '; + *ip++ = '-'; + *ip++ = '2'; + *ip++ = ' '; + } else if (*p == 'b') { + *ip++ = ' '; + *ip++ = '-'; + *ip++ = '1'; + *ip++ = ' '; + } else { + *ip++ = *p; + } prevChar = *p; } - if ((prevChar != '.') && (prevChar != 'a') && (prevChar != 'b')) { + if (prevChar!='.' && prevChar!='a' && prevChar!='b') { *ip = '\0'; if (internal != NULL) { *internal = ibuf; } else { - ckfree (ibuf); + ckfree(ibuf); } if (stable != NULL) { *stable = !hasunstable; @@ -1279,9 +1361,10 @@ CheckVersionAndConvert( } error: - ckfree (ibuf); - Tcl_AppendResult(interp, "expected version number but got \"", string, - "\"", NULL); + ckfree(ibuf); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected version number but got \"%s\"", string)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSION", NULL); return TCL_ERROR; } @@ -1306,30 +1389,29 @@ CheckVersionAndConvert( static int CompareVersions( - char *v1, /* Versions strings, of form 2.1.3 (any number */ - char *v2, /* of version numbers). */ - int *isMajorPtr) /* If non-null, the word pointed to is filled - * in with a 0/1 value. 1 means that the difference - * occured in the first element. */ + char *v1, char *v2, /* Versions strings, of form 2.1.3 (any number + * of version numbers). */ + int *isMajorPtr) /* If non-null, the word pointed to is filled + * in with a 0/1 value. 1 means that the + * difference occured in the first element. */ { - int thisIsMajor; - int res, flip; - char* s1, *e1, *s2, *e2, o1, o2; + int thisIsMajor, res, flip; + char *s1, *e1, *s2, *e2, o1, o2; /* * Each iteration of the following loop processes one number from each - * string, terminated by a " " (space). If those numbers don't match then the - * comparison is over; otherwise, we loop back for the next number. + * string, terminated by a " " (space). If those numbers don't match then + * the comparison is over; otherwise, we loop back for the next number. * * TIP 268. * This is identical the function 'ComparePkgVersion', but using the new * space separator as used by the internal rep of version numbers. The * special separators 'a' and 'b' have already been dealt with in - * 'CheckVersionAndConvert', they were translated into numbers as - * well. This keeps the comparison sane. Otherwise we would have to - * compare numerics, the separators, and also deal with the special case - * of end-of-string compared to separators. The semi-list rep we get here - * is much easier to handle, as it is still regular. + * 'CheckVersionAndConvert', they were translated into numbers as well. + * This keeps the comparison sane. Otherwise we would have to compare + * numerics, the separators, and also deal with the special case of + * end-of-string compared to separators. The semi-list rep we get here is + * much easier to handle, as it is still regular. * * Rewritten to not compute a numeric value for the extracted version * number, but do string comparison. Skip any leading zeros for that to @@ -1342,13 +1424,17 @@ CompareVersions( while (1) { /* - * Parse one decimal number from the front of each string. - * Skip leading zeros. Terminate found number for upcoming - * string-wise comparison, if needed. + * Parse one decimal number from the front of each string. Skip + * leading zeros. Terminate found number for upcoming string-wise + * comparison, if needed. */ - while ((*s1 != 0) && (*s1 == '0')) { s1 ++; } - while ((*s2 != 0) && (*s2 == '0')) { s2 ++; } + while ((*s1 != 0) && (*s1 == '0')) { + s1++; + } + while ((*s2 != 0) && (*s2 == '0')) { + s2++; + } /* * s1, s2 now point to the beginnings of the numbers to compare. Test @@ -1371,8 +1457,8 @@ CompareVersions( if ((*s1 == '-') && (*s2 == '-')) { /* a < b => -a > -b, etc. */ - s1 ++; - s2 ++; + s1++; + s2++; flip = 1; } else { flip = 0; @@ -1383,12 +1469,18 @@ CompareVersions( * numbers end. */ - e1 = s1; while ((*e1 != 0) && (*e1 != ' ')) { e1 ++; } - e2 = s2; while ((*e2 != 0) && (*e2 != ' ')) { e2 ++; } + e1 = s1; + while ((*e1 != 0) && (*e1 != ' ')) { + e1++; + } + e2 = s2; + while ((*e2 != 0) && (*e2 != ' ')) { + e2++; + } /* * s1 .. e1 and s2 .. e2 now bracket the numbers to compare. Insert - * terminators, compare, and restore actual contents. First however + * terminators, compare, and restore actual contents. First however * another shortcut. Compare lengths. Shorter string is smaller * number! Thus we strcmp only strings of identical length. */ @@ -1398,10 +1490,12 @@ CompareVersions( } else if ((e2-s2) < (e1-s1)) { res = 1; } else { - o1 = *e1 ; *e1 = '\0'; - o2 = *e2 ; *e2 = '\0'; + o1 = *e1; + *e1 = '\0'; + o2 = *e2; + *e2 = '\0'; - res = strcmp (s1, s2); + res = strcmp(s1, s2); res = (res < 0) ? -1 : (res ? 1 : 0); *e1 = o1; @@ -1414,7 +1508,9 @@ CompareVersions( */ if (res != 0) { - if (flip) res = -res; + if (flip) { + res = -res; + } break; } @@ -1430,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; } @@ -1452,13 +1551,12 @@ CompareVersions( * * CheckAllRequirements -- * - * This function checks to see whether all requirements in a set - * have valid syntax. + * This function checks to see whether all requirements in a set have + * valid syntax. * * Results: - * TCL_OK is returned if all requirements are valid. - * Otherwise TCL_ERROR is returned and an error message - * is left in the interp's result. + * TCL_OK is returned if all requirements are valid. Otherwise TCL_ERROR + * is returned and an error message is left in the interp's result. * * Side effects: * May modify the interpreter result. @@ -1468,13 +1566,14 @@ CompareVersions( static int CheckAllRequirements( - Tcl_Interp* interp, - int reqc, /* Requirements to check. */ - Tcl_Obj *CONST reqv[]) + Tcl_Interp *interp, + int reqc, /* Requirements to check. */ + Tcl_Obj *const reqv[]) { int i; + for (i = 0; i < reqc; i++) { - if ((CheckRequirement(interp, Tcl_GetString(reqv[i])) != TCL_OK)) { + if ((CheckRequirement(interp, TclGetString(reqv[i])) != TCL_OK)) { return TCL_ERROR; } } @@ -1502,46 +1601,56 @@ 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 - * = version-version - * = version- + /* + * Syntax of requirement = version + * = version-version + * = version- */ - char* dash = NULL; - char* buf; + char *dash = NULL, *buf; - dash = strchr (string, '-'); + dash = strchr(string, '-'); if (dash == NULL) { - /* no dash found, has to be a simple version */ - return CheckVersionAndConvert (interp, string, NULL, NULL); + /* + * No dash found, has to be a simple version. + */ + + return CheckVersionAndConvert(interp, string, NULL, NULL); } - if (strchr (dash+1, '-') != NULL) { - /* More dashes found after the first. This is wrong. */ - Tcl_AppendResult(interp, "expected versionMin-versionMax but got \"", string, - "\"", NULL); + + if (strchr(dash+1, '-') != NULL) { + /* + * More dashes found after the first. This is wrong. + */ + + 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 + /* + * 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(). */ - buf = strdup (string); - dash = buf + (dash - string); - *dash = '\0'; /* buf now <=> min part */ - dash ++; /* dash now <=> max part */ + DupString(buf, string); + dash = buf + (dash - string); + *dash = '\0'; /* buf now <=> min part */ + dash++; /* dash now <=> max part */ if ((CheckVersionAndConvert(interp, buf, NULL, NULL) != TCL_OK) || - ((*dash != '\0') && - (CheckVersionAndConvert(interp, dash, NULL, NULL) != TCL_OK))) { - free (buf); + ((*dash != '\0') && + (CheckVersionAndConvert(interp, dash, NULL, NULL) != TCL_OK))) { + ckfree(buf); return TCL_ERROR; } - free (buf); + ckfree(buf); return TCL_OK; } @@ -1563,14 +1672,23 @@ CheckRequirement( static void AddRequirementsToResult( - Tcl_Interp* interp, - int reqc, /* Requirements constraining the desired version. */ - Tcl_Obj *CONST reqv[]) /* 0 means to use the latest version available. */ + Tcl_Interp *interp, + int reqc, /* Requirements constraining the desired + * version. */ + Tcl_Obj *const reqv[]) /* 0 means to use the latest version + * available. */ { - if (reqc > 0) { - int i; - for (i = 0; i < reqc; i++) { - Tcl_AppendResult(interp, " ", TclGetString(reqv[i]), NULL); + Tcl_Obj *result = Tcl_GetObjResult(interp); + int 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_AppendPrintfToObj(result, " exactly %s", v+((length+1)/2)); + } else { + Tcl_AppendPrintfToObj(result, " %s", v); } } } @@ -1593,32 +1711,36 @@ AddRequirementsToResult( static void AddRequirementsToDString( - Tcl_DString* dstring, - int reqc, /* Requirements constraining the desired version. */ - Tcl_Obj *CONST reqv[]) /* 0 means to use the latest version available. */ + Tcl_DString *dsPtr, + int reqc, /* Requirements constraining the desired + * version. */ + Tcl_Obj *const reqv[]) /* 0 means to use the latest version + * available. */ { + int i; + if (reqc > 0) { - int i; for (i = 0; i < reqc; i++) { - Tcl_DStringAppend(dstring, " ", 1); - Tcl_DStringAppend(dstring, 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. + * This function checks to see whether a version satisfies at least one + * of a set of requirements. * * Results: - * If the requirements are satisfied 1 is returned. - * Otherwise 0 is returned. The function assumes - * that all pieces have valid syntax. And is allowed - * to make that assumption. + * If the requirements are satisfied 1 is returned. Otherwise 0 is + * returned. The function assumes that all pieces have valid syntax. And + * is allowed to make that assumption. * * Side effects: * None. @@ -1627,18 +1749,22 @@ AddRequirementsToDString( */ static int -AllRequirementsSatisfied( - 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 available. */ +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 + * available. */ { - int i, satisfies; + int i; - for (satisfies = i = 0; i < reqc; i++) { - satisfies = RequirementSatisfied(availVersionI, Tcl_GetString(reqv[i])); - if (satisfies) break; + for (i = 0; i < reqc; i++) { + if (RequirementSatisfied(availVersionI, TclGetString(reqv[i]))) { + return 1; + } } - return satisfies; + return 0; } /* @@ -1649,10 +1775,9 @@ AllRequirementsSatisfied( * This function checks to see whether a version satisfies a requirement. * * Results: - * If the requirement is satisfied 1 is returned. - * Otherwise 0 is returned. The function assumes - * that all pieces have valid syntax. And is allowed - * to make that assumption. + * If the requirement is satisfied 1 is returned. Otherwise 0 is + * returned. The function assumes that all pieces have valid syntax, and + * is allowed to make that assumption. * * Side effects: * None. @@ -1662,93 +1787,99 @@ AllRequirementsSatisfied( static int RequirementSatisfied( - char *havei, /* Version string, of candidate package we have */ - CONST char *req) /* Requirement string the candidate has to satisfy */ + char *havei, /* Version string, of candidate package we + * have. */ + const char *req) /* Requirement string the candidate has to + * satisfy. */ { - /* The have candidate is already in internal rep. */ + /* + * The have candidate is already in internal rep. + */ int satisfied, res; - char* dash = NULL; - char* buf, *min, *max; + char *dash = NULL, *buf, *min, *max; - dash = strchr (req, '-'); + dash = strchr(req, '-'); if (dash == NULL) { - /* No dash found, is a simple version, fallback to regular check. - * The 'CheckVersionAndConvert' cannot fail. We pad the requirement with + /* + * No dash found, is a simple version, fallback to regular check. The + * 'CheckVersionAndConvert' cannot fail. We pad the requirement with * 'a0', i.e '-2' before doing the comparison to properly accept * unstables as well. */ - char* reqi = NULL; + char *reqi = NULL; int thisIsMajor; - CheckVersionAndConvert (NULL, req, &reqi, NULL); - strcat (reqi, " -2"); - res = CompareVersions(havei, reqi, &thisIsMajor); + CheckVersionAndConvert(NULL, req, &reqi, NULL); + strcat(reqi, " -2"); + res = CompareVersions(havei, reqi, &thisIsMajor); satisfied = (res == 0) || ((res == 1) && !thisIsMajor); - Tcl_Free (reqi); + ckfree(reqi); return satisfied; } - /* Exactly one dash is present (Assumption of valid syntax). Copy the req, - * split at the location of dash and check that both parts are - * versions. Note that the max part can be empty. + /* + * Exactly one dash is present (Assumption of valid syntax). Copy the req, + * split at the location of dash and check that both parts are versions. + * Note that the max part can be empty. */ - buf = strdup (req); - dash = buf + (dash - req); - *dash = '\0'; /* buf now <=> min part */ - dash ++; /* dash now <=> max part */ + DupString(buf, req); + dash = buf + (dash - req); + *dash = '\0'; /* buf now <=> min part */ + dash++; /* dash now <=> max part */ if (*dash == '\0') { - /* We have a min, but no max. For the comparison we generate the + /* + * We have a min, but no max. For the comparison we generate the * internal rep, padded with 'a0' i.e. '-2'. */ - /* No max part, unbound */ - - CheckVersionAndConvert (NULL, buf, &min, NULL); - strcat (min, " -2"); + CheckVersionAndConvert(NULL, buf, &min, NULL); + strcat(min, " -2"); satisfied = (CompareVersions(havei, min, NULL) >= 0); - Tcl_Free (min); - free (buf); + ckfree(min); + ckfree(buf); return satisfied; } - /* We have both min and max, and generate their internal reps. - * When identical we compare as is, otherwise we pad with 'a0' - * to ove the range a bit. + /* + * We have both min and max, and generate their internal reps. When + * identical we compare as is, otherwise we pad with 'a0' to ove the range + * a bit. */ - CheckVersionAndConvert (NULL, buf, &min, NULL); - CheckVersionAndConvert (NULL, dash, &max, NULL); + CheckVersionAndConvert(NULL, buf, &min, NULL); + CheckVersionAndConvert(NULL, dash, &max, NULL); if (CompareVersions(min, max, NULL) == 0) { satisfied = (CompareVersions(min, havei, NULL) == 0); } else { - strcat (min, " -2"); - strcat (max, " -2"); + strcat(min, " -2"); + strcat(max, " -2"); satisfied = ((CompareVersions(min, havei, NULL) <= 0) && - (CompareVersions(havei, max, NULL) < 0)); + (CompareVersions(havei, max, NULL) < 0)); } - Tcl_Free (min); - Tcl_Free (max); - free (buf); + ckfree(min); + ckfree(max); + ckfree(buf); return satisfied; } /* *---------------------------------------------------------------------- * - * 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. @@ -1756,103 +1887,33 @@ RequirementSatisfied( *---------------------------------------------------------------------- */ -static Tcl_Obj* -ExactRequirement(version) - 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" - */ + const char *actualVersion = Tcl_PkgPresent(interp, "Tcl", version, 0); - char* iv; - int lc, i; - CONST char** lv; - char buf [30]; - Tcl_Obj* o = Tcl_NewStringObj (version,-1); - Tcl_AppendStringsToObj (o, "-", 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 (o, lv[i], NULL); - /* Separator component */ - i ++; - if (0 == strcmp ("-1", lv[i])) { - Tcl_AppendStringsToObj (o, "b", NULL); - } else if (0 == strcmp ("-2", lv[i])) { - Tcl_AppendStringsToObj (o, "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 (o, ".", NULL); + return Tcl_PkgPresent(interp, "Tcl", version, 1); } } - /* Regular component, last */ - sprintf (buf, "%d", atoi (lv [lc-1]) + 1); - Tcl_AppendStringsToObj (o, buf, NULL); - - ckfree ((char*) iv); - ckfree ((char*) lv); - return o; + return actualVersion; } - -/* - *---------------------------------------------------------------------- - * - * 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 = (Tcl_Obj*) clientData; - if (ov != NULL) { - Tcl_DecrRefCount (ov); - } -} - /* * Local Variables: * mode: c |