diff options
| -rw-r--r-- | ChangeLog | 8 | ||||
| -rw-r--r-- | generic/tclPkg.c | 1286 | ||||
| -rw-r--r-- | tests/pkg.test | 22 |
3 files changed, 502 insertions, 814 deletions
@@ -1,7 +1,13 @@ -2007-09-18 Don Porter <dgp@users.sourceforge.net> +2007-09-19 Don Porter <dgp@users.sourceforge.net> *** 8.4.16 TAGGED FOR RELEASE *** + * generic/tclPkg.c: Backport fix for [1573844] to the + * tests/pkg.test: TCL_TIP268 sections. + +2007-09-18 Don Porter <dgp@users.sourceforge.net> + + * changes: updates for 8.4.16 release. 2007-09-15 Daniel Steffen <das@users.sourceforge.net> diff --git a/generic/tclPkg.c b/generic/tclPkg.c index df209ea..159c87b 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -10,7 +10,7 @@ * 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.9.2.9 2007/03/19 17:06:26 dgp Exp $ + * RCS: @(#) $Id: tclPkg.c,v 1.9.2.10 2007/09/19 09:23:59 dgp Exp $ * * TIP #268. * Heavily rewritten to handle the extend version numbers, and extended @@ -64,25 +64,39 @@ static int ComparePkgVersions _ANSI_ARGS_((CONST char *v1, static Package * FindPackage _ANSI_ARGS_((Tcl_Interp *interp, CONST char *name)); #else -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(CONST char *v1i, CONST 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(CONST char *havei, CONST char *req); -static int AllRequirementsSatisfied(CONST char *havei, - int reqc, Tcl_Obj *CONST reqv[]); -static void AddRequirementsToResult(Tcl_Interp* interp, - int reqc, Tcl_Obj *CONST reqv[]); + 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[]); + 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); +static const char * PkgRequireCore(Tcl_Interp *interp, CONST char *name, + int reqx, Tcl_Obj *CONST reqv[], + ClientData *clientDataPtr); #endif + +/* + * 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) + /* *---------------------------------------------------------------------- @@ -135,8 +149,7 @@ Tcl_PkgProvideEx(interp, name, version, clientData) 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; } @@ -146,13 +159,13 @@ Tcl_PkgProvideEx(interp, name, version, clientData) if (CheckVersionAndConvert (interp, pkgPtr->version, &pvi, NULL) != TCL_OK) { return TCL_ERROR; } else if (CheckVersionAndConvert (interp, version, &vi, NULL) != TCL_OK) { - Tcl_Free (pvi); + ckfree(pvi); return TCL_ERROR; } res = CompareVersions(pvi, vi, NULL); - Tcl_Free (pvi); - Tcl_Free (vi); + ckfree(pvi); + ckfree(vi); if (res == 0) { #endif @@ -250,7 +263,7 @@ Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr) Tcl_DString command; #else Tcl_Obj *ov; - int res; + const char *result = NULL; #endif /* @@ -333,65 +346,61 @@ Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr) /* 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); Tcl_DecrRefCount (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. */ + ClientData *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(interp,name,reqc,reqv,clientDataPtr) - Tcl_Interp *interp; /* Interpreter in which package is now +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. */ + ClientData *clientDataPtr) { Interp *iPtr = (Interp *) interp; Package *pkgPtr; - PkgAvail *availPtr, *bestPtr, *bestStablePtr; - char *availVersion, *bestVersion; /* Internal rep. of versions */ - int availStable; + PkgAvail *availPtr, *bestPtr, *bestStablePtr; + char *availVersion, *bestVersion; /* Internal rep. of versions */ + int availStable; char *script; int code, satisfies, pass; Tcl_DString command; @@ -418,17 +427,16 @@ Tcl_PkgRequireProc(interp,name,reqc,reqv,clientDataPtr) if (pkgPtr->clientData != NULL) { Tcl_AppendResult(interp, "circular package dependency: ", - "attempt to provide ", name, " ", - (char *)(pkgPtr->clientData), " requires ", name, NULL); + "attempt to provide ", name, " ", + (char *)(pkgPtr->clientData), " requires ", name, NULL); #ifndef TCL_TIP268 if (version != NULL) { Tcl_AppendResult(interp, " ", version, NULL); } - return NULL; #else AddRequirementsToResult (interp, reqc, reqv); - return TCL_ERROR; #endif + return NULL; } /* @@ -445,16 +453,15 @@ Tcl_PkgRequireProc(interp,name,reqc,reqv,clientDataPtr) if ((bestPtr != NULL) && (ComparePkgVersions(availPtr->version, bestPtr->version, (int *) NULL) <= 0)) { #else - 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 + 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 has invalid syntax. This * should not happen. This should have been caught by the * 'package ifneeded' registering the package. */ @@ -469,11 +476,14 @@ Tcl_PkgRequireProc(interp,name,reqc,reqv,clientDataPtr) #else if (bestPtr != NULL) { 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; #endif continue; @@ -484,24 +494,30 @@ Tcl_PkgRequireProc(interp,name,reqc,reqv,clientDataPtr) /* 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); #endif if (!satisfies) { #ifdef TCL_TIP268 - Tcl_Free (availVersion); + ckfree(availVersion); availVersion = NULL; #endif continue; } } + bestPtr = availPtr; + #ifdef TCL_TIP268 - if (bestVersion != NULL) Tcl_Free (bestVersion); - bestVersion = availVersion; + if (bestVersion != NULL) { + ckfree(bestVersion); + } + bestVersion = availVersion; availVersion = NULL; - /* 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. */ @@ -511,7 +527,7 @@ Tcl_PkgRequireProc(interp,name,reqc,reqv,clientDataPtr) } if (bestVersion != NULL) { - Tcl_Free (bestVersion); + ckfree(bestVersion); } /* Now choose a version among the two best. For 'latest' we simply @@ -519,7 +535,8 @@ Tcl_PkgRequireProc(interp,name,reqc,reqv,clientDataPtr) * 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; #endif } @@ -533,11 +550,13 @@ Tcl_PkgRequireProc(interp,name,reqc,reqv,clientDataPtr) CONST char *versionToProvide = bestPtr->version; script = bestPtr->script; + pkgPtr->clientData = (ClientData) versionToProvide; Tcl_Preserve((ClientData) script); Tcl_Preserve((ClientData) versionToProvide); code = Tcl_EvalEx(interp, script, -1, TCL_EVAL_GLOBAL); Tcl_Release((ClientData) script); + pkgPtr = FindPackage(interp, name); if (code == TCL_OK) { #ifdef TCL_TIP268 @@ -549,9 +568,9 @@ Tcl_PkgRequireProc(interp,name,reqc,reqv,clientDataPtr) #endif code = TCL_ERROR; Tcl_AppendResult(interp, "attempt to provide package ", - name, " ", versionToProvide, - " failed: no version of package ", name, - " provided", NULL); + name, " ", versionToProvide, + " failed: no version of package ", name, + " provided", NULL); #ifndef TCL_TIP268 } else if (0 != ComparePkgVersions( pkgPtr->version, versionToProvide, NULL)) { @@ -592,124 +611,89 @@ Tcl_PkgRequireProc(interp,name,reqc,reqv,clientDataPtr) " provided instead", NULL); #else } else { - char* pvi; - char* vi; + char *pvi, *vi; int res; - 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 (vi); + ckfree(vi); if (res != 0) { /* At this point, it is clear that a prior * [package ifneeded] command lied to us. It said * that to get a particular version of a particular - * package, we needed to evaluate a particular script. - * However, we evaluated that script and got a different - * version than we were told. This is an error, and we - * ought to report it. + * package, we needed to evaluate a particular + * script. However, we evaluated that script and + * got a different version than we were told. + * This is an error, and we ought to report it. * - * However, we've been letting this type of error slide - * for a long time, and as a result, a lot of packages - * suffer from them. + * However, we've been letting this type of error + * slide for a long time, and as a result, a lot + * of packages suffer from them. * * It's a bit too harsh to make a large number of * existing packages start failing by releasing a - * new patch release, so we forgive this type of error - * for the rest of the Tcl 8.4 series. + * new patch release, so we forgive this type of + * error for the rest of the Tcl 8.4 series. * - * We considered reporting a warning, but in practice - * even that appears too harsh a change for a patch release. + * We considered reporting a warning, but in + * practice even that appears too harsh a change + * for a patch release. * - * We limit the error reporting to only - * the situation where a broken ifneeded script leads + * We limit the error reporting to only the + * situation where a broken ifneeded script leads * to a failure to satisfy the requirement. */ if (reqc > 0) { - satisfies = AllRequirementsSatisfied (pvi, reqc, reqv); + satisfies = SomeRequirementSatisfied(pvi, + reqc, reqv); if (!satisfies) { - Tcl_ResetResult(interp); code = TCL_ERROR; Tcl_AppendResult(interp, - "attempt to provide package ", name, " ", - versionToProvide, " failed: package ", - name, " ", pkgPtr->version, - " provided instead", NULL); + "attempt to provide package ", + name, " ", versionToProvide, + " failed: package ", name, " ", + pkgPtr->version, + " provided instead", NULL); } } - /* - * Warning generation now disabled - if (code == TCL_OK) { - Tcl_Obj *msg = Tcl_NewStringObj( - "attempt to provide package ", -1); - Tcl_Obj *cmdPtr = Tcl_NewListObj(0, NULL); - Tcl_ListObjAppendElement(NULL, cmdPtr, - Tcl_NewStringObj("tclLog", -1)); - Tcl_AppendStringsToObj(msg, name, " ", versionToProvide, - " failed: package ", name, " ", - pkgPtr->version, " provided instead", NULL); - Tcl_ListObjAppendElement(NULL, cmdPtr, msg); - Tcl_IncrRefCount(cmdPtr); - Tcl_EvalObjEx(interp, cmdPtr, TCL_EVAL_GLOBAL); - Tcl_DecrRefCount(cmdPtr); - Tcl_ResetResult(interp); - } - */ #endif } #ifdef TCL_TIP268 - Tcl_Free (pvi); + ckfree(pvi); #endif } -#ifndef TCL_TIP268 - /* - * Warning generation now disabled - if (code == TCL_OK) { - Tcl_Obj *msg = Tcl_NewStringObj( - "attempt to provide package ", -1); - Tcl_Obj *cmdPtr = Tcl_NewListObj(0, NULL); - Tcl_ListObjAppendElement(NULL, cmdPtr, - Tcl_NewStringObj("tclLog", -1)); - Tcl_AppendStringsToObj(msg, name, " ", versionToProvide, - " failed: package ", name, " ", - pkgPtr->version, " provided instead", NULL); - Tcl_ListObjAppendElement(NULL, cmdPtr, msg); - Tcl_IncrRefCount(cmdPtr); - Tcl_EvalObjEx(interp, cmdPtr, TCL_EVAL_GLOBAL); - Tcl_DecrRefCount(cmdPtr); - Tcl_ResetResult(interp); - } - */ -#endif } } 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); + name, " ", versionToProvide, " failed: ", + "bad return code: ", Tcl_GetString(codePtr), NULL); Tcl_DecrRefCount(codePtr); code = TCL_ERROR; } + Tcl_Release((ClientData) 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. */ Tcl_AddErrorInfo(interp, "\n (\"package ifneeded\" script)"); if (pkgPtr->version != NULL) { @@ -717,12 +701,9 @@ Tcl_PkgRequireProc(interp,name,reqc,reqv,clientDataPtr) pkgPtr->version = NULL; } pkgPtr->clientData = NULL; -#ifndef TCL_TIP268 return NULL; -#else - return TCL_ERROR; -#endif } + break; } @@ -735,6 +716,7 @@ Tcl_PkgRequireProc(interp,name,reqc,reqv,clientDataPtr) if (pass > 1) { break; } + script = ((Interp *) interp)->packageUnknown; if (script != NULL) { Tcl_DStringInit(&command); @@ -753,21 +735,18 @@ Tcl_PkgRequireProc(interp,name,reqc,reqv,clientDataPtr) code = Tcl_EvalEx(interp, Tcl_DStringValue(&command), Tcl_DStringLength(&command), TCL_EVAL_GLOBAL); Tcl_DStringFree(&command); + if ((code != TCL_OK) && (code != TCL_ERROR)) { Tcl_Obj *codePtr = Tcl_NewIntObj(code); Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad return code: ", - Tcl_GetString(codePtr), NULL); + Tcl_GetString(codePtr), NULL); Tcl_DecrRefCount(codePtr); code = TCL_ERROR; } if (code == TCL_ERROR) { Tcl_AddErrorInfo(interp, "\n (\"package unknown\" script)"); -#ifndef TCL_TIP268 return NULL; -#else - return TCL_ERROR; -#endif } Tcl_ResetResult(interp); } @@ -779,11 +758,10 @@ Tcl_PkgRequireProc(interp,name,reqc,reqv,clientDataPtr) if (version != NULL) { Tcl_AppendResult(interp, " ", version, (char *) NULL); } - return NULL; #else AddRequirementsToResult(interp, reqc, reqv); - return TCL_ERROR; #endif + return NULL; } /* @@ -801,10 +779,10 @@ Tcl_PkgRequireProc(interp,name,reqc,reqv,clientDataPtr) if (reqc == 0) { satisfies = 1; } else { - CheckVersionAndConvert (interp, pkgPtr->version, &pkgVersionI, NULL); - satisfies = AllRequirementsSatisfied (pkgVersionI, reqc, reqv); + CheckVersionAndConvert(interp, pkgPtr->version, &pkgVersionI, NULL); + satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv); - Tcl_Free (pkgVersionI); + ckfree(pkgVersionI); #endif } #ifndef TCL_TIP268 @@ -816,23 +794,17 @@ Tcl_PkgRequireProc(interp,name,reqc,reqv,clientDataPtr) if (clientDataPtr) { *clientDataPtr = pkgPtr->clientData; } -#ifndef TCL_TIP268 return pkgPtr->version; -#else - Tcl_SetObjResult (interp, Tcl_NewStringObj (pkgPtr->version, -1)); - return TCL_OK; -#endif } - Tcl_AppendResult(interp, "version conflict for package \"", - name, "\": have ", pkgPtr->version, + Tcl_AppendResult(interp, "version conflict for package \"", name, + "\": have ", pkgPtr->version, #ifndef TCL_TIP268 - ", need ", version, (char *) NULL); - return NULL; + ", need ", version, (char *) NULL); #else - ", need", (char*) NULL); + ", need", (char*) NULL); AddRequirementsToResult (interp, reqc, reqv); - return TCL_ERROR; #endif + return NULL; } /* @@ -891,64 +863,28 @@ Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr) 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); if (pkgPtr->version != NULL) { -#ifdef TCL_TIP268 - char* pvi; - char* vi; - int thisIsMajor; -#endif /* * 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; - } -#ifndef TCL_TIP268 - result = ComparePkgVersions(pkgPtr->version, version, &satisfies); -#else - 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); - satisfies = (result == 0) || ((result == 1) && !thisIsMajor); -#endif - if ((satisfies && !exact) || (result == 0)) { - if (clientDataPtr) { - *clientDataPtr = pkgPtr->clientData; - } - - return pkgPtr->version; - } - Tcl_AppendResult(interp, "version conflict for package \"", - name, "\": have ", pkgPtr->version, - ", need ", version, (char *) NULL); - return NULL; + return Tcl_PkgRequireEx(interp, name, version, exact, + clientDataPtr); } } if (version != NULL) { Tcl_AppendResult(interp, "package ", name, " ", version, - " is not present", (char *) NULL); + " is not present", NULL); } else { - Tcl_AppendResult(interp, "package ", name, " is not present", - (char *) NULL); + Tcl_AppendResult(interp, "package ", name, " is not present", NULL); } return NULL; } @@ -1018,31 +954,6 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } switch ((enum pkgOptions) optionIndex) { -#ifndef TCL_TIP268 - case PKG_FORGET: { - char *keyString; - for (i = 2; i < objc; i++) { - keyString = Tcl_GetString(objv[i]); - hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString); - if (hPtr == NULL) { - continue; - } - pkgPtr = (Package *) Tcl_GetHashValue(hPtr); - Tcl_DeleteHashEntry(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); - } - ckfree((char *) pkgPtr); - } - break; -#else case PKG_FORGET: { char *keyString; for (i = 2; i < objc; i++) { @@ -1069,140 +980,87 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) } case PKG_IFNEEDED: { int length; - char* argv3i; - char* avi; +#ifdef TCL_TIP268 int res; + char *argv3i, *avi; +#endif if ((objc != 4) && (objc != 5)) { Tcl_WrongNumArgs(interp, 2, objv, "package version ?script?"); return TCL_ERROR; } argv3 = Tcl_GetString(objv[3]); +#ifdef TCL_TIP268 if (CheckVersionAndConvert(interp, argv3, &argv3i, NULL) != TCL_OK) { - return TCL_ERROR; +#else + if (CheckVersion(interp, argv3) != TCL_OK) { #endif + return TCL_ERROR; } -#ifndef TCL_TIP268 - case PKG_IFNEEDED: { - int length; - if ((objc != 4) && (objc != 5)) { - Tcl_WrongNumArgs(interp, 2, objv, "package version ?script?"); - return TCL_ERROR; -#else argv2 = Tcl_GetString(objv[2]); if (objc == 4) { hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); if (hPtr == NULL) { - Tcl_Free (argv3i); - return TCL_OK; +#ifdef TCL_TIP268 + ckfree(argv3i); #endif + return TCL_OK; } -#ifndef TCL_TIP268 - argv3 = Tcl_GetString(objv[3]); - if (CheckVersion(interp, argv3) != TCL_OK) { -#else pkgPtr = (Package *) Tcl_GetHashValue(hPtr); } else { pkgPtr = FindPackage(interp, argv2); } argv3 = Tcl_GetStringFromObj(objv[3], &length); - for (availPtr = pkgPtr->availPtr, prevPtr = NULL; - availPtr != NULL; + 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); -#endif +#ifdef TCL_TIP268 + if (CheckVersionAndConvert(interp, availPtr->version, &avi, + NULL) != TCL_OK) { + ckfree(argv3i); return TCL_ERROR; } -#ifndef TCL_TIP268 - argv2 = Tcl_GetString(objv[2]); - if (objc == 4) { - hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); - if (hPtr == NULL) { -#else res = CompareVersions(avi, argv3i, NULL); - Tcl_Free (avi); + ckfree(avi); if (res == 0){ +#else + if (ComparePkgVersions(availPtr->version, argv3, (int *) NULL) + == 0) { +#endif if (objc == 4) { - Tcl_Free (argv3i); - Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE); +#ifdef TCL_TIP268 + ckfree(argv3i); #endif + Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE); return TCL_OK; } -#ifndef TCL_TIP268 - pkgPtr = (Package *) 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 (ComparePkgVersions(availPtr->version, argv3, (int *) NULL) - == 0) { - if (objc == 4) { - Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE); - return TCL_OK; - } - Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); - break; - } - } - if (objc == 4) { - return TCL_OK; -#else Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); break; -#endif } -#ifndef TCL_TIP268 - if (availPtr == NULL) { - availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail)); - availPtr->version = ckalloc((unsigned) (length + 1)); - strcpy(availPtr->version, argv3); - if (prevPtr == NULL) { - availPtr->nextPtr = pkgPtr->availPtr; - pkgPtr->availPtr = availPtr; - } else { - availPtr->nextPtr = prevPtr->nextPtr; - prevPtr->nextPtr = availPtr; - } -#else } - Tcl_Free (argv3i); +#ifdef TCL_TIP268 + ckfree(argv3i); +#endif if (objc == 4) { return TCL_OK; } if (availPtr == NULL) { availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail)); - availPtr->version = ckalloc((unsigned) (length + 1)); - strcpy(availPtr->version, argv3); + DupBlock(availPtr->version, argv3, (unsigned) length + 1); + if (prevPtr == NULL) { availPtr->nextPtr = pkgPtr->availPtr; pkgPtr->availPtr = availPtr; } else { availPtr->nextPtr = prevPtr->nextPtr; prevPtr->nextPtr = availPtr; -#endif } -#ifndef TCL_TIP268 - argv4 = Tcl_GetStringFromObj(objv[4], &length); - availPtr->script = ckalloc((unsigned) (length + 1)); - strcpy(availPtr->script, argv4); - break; -#endif } -#ifndef TCL_TIP268 - case PKG_NAMES: { - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); -#else 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: { @@ -1221,42 +1079,58 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) break; } 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]); 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; + } } +#ifndef TCL_TIP268 version = NULL; if (objc == (4 + exact)) { version = Tcl_GetString(objv[3 + exact]); - if (CheckVersionAndConvert(interp, version, NULL, NULL) != TCL_OK) { -#endif + if (CheckVersion(interp, version) != TCL_OK) { return TCL_ERROR; } -#ifndef TCL_TIP268 - tablePtr = &iPtr->packageTable; - for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; - hPtr = Tcl_NextHashEntry(&search)) { -#else } else if ((objc != 3) || exact) { - goto presentSyntax; + goto requireSyntax; } +#else + version = NULL; if (exact) { - argv3 = Tcl_GetString(objv[3]); - version = Tcl_PkgPresent(interp, argv3, version, exact); + version = Tcl_GetString(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 ) ); +#endif + Tcl_PkgPresent(interp, name, version, exact); + return TCL_ERROR; break; } case PKG_PROVIDE: { @@ -1268,87 +1142,81 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) if (objc == 3) { hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); if (hPtr != NULL) { -#endif pkgPtr = (Package *) Tcl_GetHashValue(hPtr); -#ifndef TCL_TIP268 - if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) { - Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr)); -#else if (pkgPtr->version != NULL) { Tcl_SetResult(interp, pkgPtr->version, TCL_VOLATILE); -#endif } } -#ifndef TCL_TIP268 - break; -#else return TCL_OK; -#endif } + argv3 = Tcl_GetString(objv[3]); #ifndef TCL_TIP268 - case PKG_PRESENT: { - if (objc < 3) { - presentSyntax: - Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?"); - return TCL_ERROR; + if (CheckVersion(interp, argv3) != TCL_OK) { #else - argv3 = Tcl_GetString(objv[3]); if (CheckVersionAndConvert(interp, argv3, NULL, NULL) != TCL_OK) { +#endif return TCL_ERROR; } return Tcl_PkgProvide(interp, argv2, argv3); } case PKG_REQUIRE: { + require: if (objc < 3) { requireSyntax: - Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?requirement...?"); +#ifndef TCL_TIP268 + Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?"); +#else + Tcl_WrongNumArgs(interp, 2, objv, + "?-exact? package ?requirement...?"); +#endif + return TCL_ERROR; + } +#ifndef TCL_TIP268 + argv2 = Tcl_GetString(objv[2]); + if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { + exact = 1; + } else { + exact = 0; + } + version = NULL; + if (objc == (4 + exact)) { + version = Tcl_GetString(objv[3 + exact]); + if (CheckVersion(interp, version) != TCL_OK) { + return TCL_ERROR; + } + } else if ((objc != 3) || exact) { + goto requireSyntax; + } + if (exact) { + argv3 = Tcl_GetString(objv[3]); + version = Tcl_PkgRequire(interp, argv3, version, exact); + } else { + version = Tcl_PkgRequire(interp, argv2, version, exact); + } + if (version == NULL) { return TCL_ERROR; } + Tcl_SetObjResult( interp, Tcl_NewStringObj( version, -1 ) ); +#else version = NULL; - argv2 = Tcl_GetString(objv[2]); + argv2 = Tcl_GetString(objv[2]); if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { Tcl_Obj* ov; int res; if (objc != 5) { goto requireSyntax; -#endif } -#ifndef TCL_TIP268 - argv2 = Tcl_GetString(objv[2]); - if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { - exact = 1; - } else { - exact = 0; -#else version = Tcl_GetString(objv[4]); if (CheckVersionAndConvert(interp, version, NULL, NULL) != TCL_OK) { return TCL_ERROR; -#endif } -#ifdef TCL_TIP268 + /* Create a new-style requirement for the exact version. */ - ov = ExactRequirement (version); -#endif + ov = Tcl_NewStringObj(version, -1); + Tcl_AppendStringsToObj(ov, "-", version, NULL); version = NULL; -#ifndef TCL_TIP268 - if (objc == (4 + exact)) { - version = Tcl_GetString(objv[3 + exact]); - if (CheckVersion(interp, version) != TCL_OK) { - return TCL_ERROR; - } - } else if ((objc != 3) || exact) { - goto presentSyntax; - } - if (exact) { - argv3 = Tcl_GetString(objv[3]); - version = Tcl_PkgPresent(interp, argv3, version, exact); - } else { - version = Tcl_PkgPresent(interp, argv2, version, exact); - } - if (version == NULL) { -#else argv3 = Tcl_GetString(objv[3]); Tcl_IncrRefCount (ov); @@ -1357,21 +1225,11 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) return res; } else { if (CheckAllRequirements (interp, objc-3, objv+3) != TCL_OK) { -#endif return TCL_ERROR; } -#ifndef TCL_TIP268 - Tcl_SetObjResult( interp, Tcl_NewStringObj( version, -1 ) ); - break; -#else return Tcl_PkgRequireProc(interp, argv2, objc-3, objv+3, NULL); -#endif } -#ifndef TCL_TIP268 - case PKG_PROVIDE: { - if ((objc != 3) && (objc != 4)) { - Tcl_WrongNumArgs(interp, 2, objv, "package ?version?"); -#else +#endif break; } case PKG_UNKNOWN: { @@ -1388,9 +1246,7 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) 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?"); @@ -1398,6 +1254,7 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) } break; } +#ifdef TCL_TIP268 case PKG_PREFER: { /* See tclInt.h for the enum, just before Interp */ static CONST char *pkgPreferOptions[] = { @@ -1410,148 +1267,58 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) } else if (objc == 3) { /* Set value. */ int new; - if (Tcl_GetIndexFromObj(interp, objv[2], pkgPreferOptions, "preference", 0, - &new) != TCL_OK) { -#endif + if (Tcl_GetIndexFromObj(interp, objv[2], pkgPreferOptions, + "preference", 0, &new) != TCL_OK) { return TCL_ERROR; } -#ifndef TCL_TIP268 - argv2 = Tcl_GetString(objv[2]); - if (objc == 3) { - hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); - if (hPtr != NULL) { - pkgPtr = (Package *) Tcl_GetHashValue(hPtr); - if (pkgPtr->version != NULL) { - Tcl_SetResult(interp, pkgPtr->version, TCL_VOLATILE); - } - } - return TCL_OK; -#else if (new < iPtr->packagePrefer) { iPtr->packagePrefer = new; -#endif - } -#ifndef TCL_TIP268 - argv3 = Tcl_GetString(objv[3]); - if (CheckVersion(interp, argv3) != TCL_OK) { - return TCL_ERROR; } - return Tcl_PkgProvide(interp, argv2, argv3); -#endif } -#ifndef TCL_TIP268 - case PKG_REQUIRE: { - if (objc < 3) { - requireSyntax: - Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?"); - return TCL_ERROR; - } - argv2 = Tcl_GetString(objv[2]); - if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { - exact = 1; - } else { - exact = 0; - } - version = NULL; - if (objc == (4 + exact)) { - version = Tcl_GetString(objv[3 + exact]); - if (CheckVersion(interp, version) != TCL_OK) { - return TCL_ERROR; - } - } else if ((objc != 3) || exact) { - goto requireSyntax; - } - if (exact) { - argv3 = Tcl_GetString(objv[3]); - version = Tcl_PkgRequire(interp, argv3, version, exact); - } else { - version = Tcl_PkgRequire(interp, argv2, version, exact); - } - if (version == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult( interp, Tcl_NewStringObj( version, -1 ) ); - break; -#else /* Always return current value. */ - Tcl_SetObjResult(interp, Tcl_NewStringObj (pkgPreferOptions [iPtr->packagePrefer], -1)); + Tcl_SetObjResult(interp, + Tcl_NewStringObj(pkgPreferOptions[iPtr->packagePrefer], -1)); break; } +#endif case PKG_VCOMPARE: { if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "version1 version2"); return TCL_ERROR; -#endif } -#ifndef TCL_TIP268 - case PKG_UNKNOWN: { - int length; - if (objc == 2) { - if (iPtr->packageUnknown != NULL) { - Tcl_SetResult(interp, iPtr->packageUnknown, TCL_VOLATILE); - } - } else if (objc == 3) { - if (iPtr->packageUnknown != NULL) { - ckfree(iPtr->packageUnknown); - } - argv2 = Tcl_GetStringFromObj(objv[2], &length); - if (argv2[0] == 0) { - iPtr->packageUnknown = NULL; - } else { - iPtr->packageUnknown = (char *) ckalloc((unsigned) - (length + 1)); - strcpy(iPtr->packageUnknown, argv2); - } - } else { - Tcl_WrongNumArgs(interp, 2, objv, "?command?"); - return TCL_ERROR; - } - break; -#else 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 */ +#ifndef TCL_TIP268 + if ((CheckVersion(interp, argv2) != TCL_OK) + || (CheckVersion(interp, argv3) != TCL_OK)) { return TCL_ERROR; -#endif } -#ifndef TCL_TIP268 - case PKG_VCOMPARE: { - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "version1 version2"); - return TCL_ERROR; - } - argv3 = Tcl_GetString(objv[3]); - argv2 = Tcl_GetString(objv[2]); - if ((CheckVersion(interp, argv2) != TCL_OK) - || (CheckVersion(interp, argv3) != TCL_OK)) { - return TCL_ERROR; - } - Tcl_SetIntObj(Tcl_GetObjResult(interp), - ComparePkgVersions(argv2, argv3, (int *) NULL)); - break; + Tcl_SetObjResult(interp, Tcl_NewIntObj( + ComparePkgVersions(argv2, argv3, (int *) NULL))); #else + 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); + Tcl_SetObjResult(interp, + Tcl_NewIntObj(CompareVersions(iva, ivb, NULL))); + ckfree(iva); + ckfree(ivb); +#endif break; } case PKG_VERSIONS: { if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "package"); return TCL_ERROR; -#endif } -#ifndef TCL_TIP268 - case PKG_VERSIONS: { - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "package"); - return TCL_ERROR; -#else argv2 = Tcl_GetString(objv[2]); hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); if (hPtr != NULL) { @@ -1559,72 +1326,50 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) for (availPtr = pkgPtr->availPtr; availPtr != NULL; availPtr = availPtr->nextPtr) { Tcl_AppendElement(interp, availPtr->version); -#endif - } -#ifndef TCL_TIP268 - 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); - } } - break; -#endif } -#ifndef TCL_TIP268 - case PKG_VSATISFIES: { - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "version1 version2"); - return TCL_ERROR; - } - argv3 = Tcl_GetString(objv[3]); - argv2 = Tcl_GetString(objv[2]); - if ((CheckVersion(interp, argv2) != TCL_OK) - || (CheckVersion(interp, argv3) != TCL_OK)) { - return TCL_ERROR; - } - ComparePkgVersions(argv2, argv3, &satisfies); - Tcl_SetIntObj(Tcl_GetObjResult(interp), satisfies); - break; -#else break; } case PKG_VSATISFIES: { +#ifdef TCL_TIP268 char* argv2i = NULL; if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, "version requirement requirement..."); + Tcl_WrongNumArgs(interp, 2, objv, + "version requirement requirement..."); return TCL_ERROR; -#endif } -#ifndef TCL_TIP268 - default: { - panic("Tcl_PackageObjCmd: bad option index to pkgOptions"); -#else argv2 = Tcl_GetString(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; -#endif } -#ifdef TCL_TIP268 - satisfies = AllRequirementsSatisfied (argv2i, objc-3, objv+3); - Tcl_Free (argv2i); + satisfies = SomeRequirementSatisfied(argv2i, objc-3, objv+3); + ckfree (argv2i); +#else + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "version1 version2"); + return TCL_ERROR; + } + argv3 = Tcl_GetString(objv[3]); + argv2 = Tcl_GetString(objv[2]); + if ((CheckVersion(interp, argv2) != TCL_OK) + || (CheckVersion(interp, argv3) != TCL_OK)) { + return TCL_ERROR; + } + ComparePkgVersions(argv2, argv3, &satisfies); +#endif - Tcl_SetIntObj(Tcl_GetObjResult(interp), satisfies); + Tcl_SetObjResult(interp, Tcl_NewIntObj(satisfies)); break; } default: { panic("Tcl_PackageObjCmd: bad option index to pkgOptions"); } -#endif } return TCL_OK; } @@ -1738,32 +1483,54 @@ TclFreePackageInfo(iPtr) *---------------------------------------------------------------------- */ -static int #ifndef TCL_TIP268 +static int CheckVersion(interp, string) Tcl_Interp *interp; /* Used for error reporting. */ CONST char *string; /* Supposedly a version number, which is * groups of decimal digits separated * by dots. */ +{ + CONST char *p = string; + char prevChar; + if (!isdigit(UCHAR(*p))) { /* INTL: digit */ + goto error; + } + for (prevChar = *p, p++; *p != 0; p++) { + if (!isdigit(UCHAR(*p)) && + ((*p != '.') || (prevChar == '.'))) { /* INTL: digit */ + goto error; + } + prevChar = *p; + } + if (prevChar != '.') { + return TCL_OK; + } + + error: + Tcl_AppendResult(interp, "expected version number but got \"", + string, "\"", (char *) NULL); + return TCL_ERROR; +} #else +static int CheckVersionAndConvert(interp, string, internal, 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. */ -#endif + int* stable; /* Flag: Version is (un)stable. */ { CONST char *p = string; char prevChar; -#ifdef TCL_TIP268 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 * (1) First character has to be a digit. @@ -1778,68 +1545,68 @@ CheckVersionAndConvert(interp, string, internal, stable) * (5) Neither 'a', nor 'b' may occur before or after a '.' */ -#endif if (!isdigit(UCHAR(*p))) { /* INTL: digit */ goto error; } -#ifdef TCL_TIP268 *ip++ = *p; -#endif for (prevChar = *p, p++; *p != 0; p++) { -#ifndef TCL_TIP268 - if (!isdigit(UCHAR(*p)) && - ((*p != '.') || (prevChar == '.'))) { /* INTL: digit */ -#else - 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 == '.')))) - ) { + 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 */ -#endif goto error; } -#ifdef TCL_TIP268 - 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; } -#endif + 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; } -#ifndef TCL_TIP268 - if (prevChar != '.') { -#else if ((prevChar != '.') && (prevChar != 'a') && (prevChar != 'b')) { *ip = '\0'; if (internal != NULL) { *internal = ibuf; } else { - Tcl_Free (ibuf); + ckfree(ibuf); } if (stable != NULL) { *stable = !hasunstable; } -#endif return TCL_OK; } error: -#ifdef TCL_TIP268 - ckfree (ibuf); -#endif + ckfree(ibuf); Tcl_AppendResult(interp, "expected version number but got \"", string, "\"", (char *) NULL); return TCL_ERROR; } +#endif /* *---------------------------------------------------------------------- @@ -1861,8 +1628,8 @@ CheckVersionAndConvert(interp, string, internal, stable) *---------------------------------------------------------------------- */ -static int #ifndef TCL_TIP268 +static int ComparePkgVersions(v1, v2, satPtr) CONST char *v1; CONST char *v2; /* Versions strings, of form 2.1.3 (any @@ -1872,24 +1639,74 @@ ComparePkgVersions(v1, v2, satPtr) * v1 "satisfies" v2: v1 is greater than * or equal to v2 and both version numbers * have the same major number. */ +{ + int thisIsMajor, n1, n2; + + /* + * 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. + */ + + thisIsMajor = 1; + while (1) { + /* Parse one decimal number from the front of each string. */ + + n1 = n2 = 0; + while ((*v1 != 0) && (*v1 != '.')) { + n1 = 10*n1 + (*v1 - '0'); + v1++; + } + while ((*v2 != 0) && (*v2 != '.')) { + n2 = 10*n2 + (*v2 - '0'); + v2++; + } + + /* + * Compare and go on to the next version number if the current numbers + * match. + */ + + if (n1 != n2) { + break; + } + if (*v1 != 0) { + v1++; + } else if (*v2 == 0) { + break; + } + if (*v2 != 0) { + v2++; + } + thisIsMajor = 0; + } + if (satPtr != NULL) { + *satPtr = (n1 == n2) || ((n1 > n2) && !thisIsMajor); + } + if (n1 > n2) { + return 1; + } else if (n1 == n2) { + return 0; + } else { + return -1; + } +} #else +static int CompareVersions(v1, v2, isMajorPtr) CONST char *v1; /* Versions strings, of form 2.1.3 (any number */ CONST 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. */ -#endif { int thisIsMajor, n1, n2; -#ifdef TCL_TIP268 int res, flip; -#endif /* * 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 @@ -1904,35 +1721,23 @@ CompareVersions(v1, v2, isMajorPtr) thisIsMajor = 1; while (1) { - /* - * Parse one decimal number from the front of each string. - */ + /* Parse one decimal number from the front of each string. */ n1 = n2 = 0; -#ifndef TCL_TIP268 - while ((*v1 != 0) && (*v1 != '.')) { -#else flip = 0; while ((*v1 != 0) && (*v1 != ' ')) { if (*v1 == '-') {flip = 1 ; v1++ ; continue;} -#endif n1 = 10*n1 + (*v1 - '0'); v1++; } -#ifndef TCL_TIP268 - while ((*v2 != 0) && (*v2 != '.')) { -#else if (flip) n1 = -n1; flip = 0; while ((*v2 != 0) && (*v2 != ' ')) { if (*v2 == '-') {flip = 1; v2++ ; continue;} -#endif n2 = 10*n2 + (*v2 - '0'); v2++; } -#ifdef TCL_TIP268 if (flip) n2 = -n2; -#endif /* * Compare and go on to the next version number if the current numbers @@ -1952,27 +1757,11 @@ CompareVersions(v1, v2, isMajorPtr) } thisIsMajor = 0; } -#ifndef TCL_TIP268 - if (satPtr != NULL) { - *satPtr = (n1 == n2) || ((n1 > n2) && !thisIsMajor); - } -#endif if (n1 > n2) { -#ifndef TCL_TIP268 - return 1; -#else res = 1; -#endif } else if (n1 == n2) { -#ifndef TCL_TIP268 - return 0; -#else res = 0; -#endif } else { -#ifndef TCL_TIP268 - return -1; -#else res = -1; } @@ -2055,35 +1844,31 @@ CheckRequirement(interp, string) } if (strchr (dash+1, '-') != NULL) { /* More dashes found after the first. This is wrong. */ - Tcl_AppendResult(interp, "expected versionMin-versionMax but got \"", string, - "\"", NULL); + Tcl_AppendResult(interp, "expected versionMin-versionMax but got \"", + string, "\"", NULL); return TCL_ERROR; -#endif } -#ifdef TCL_TIP268 /* 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. */ - buf = strdup (string); - dash = buf + (dash - string); + 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); + if ((CheckVersionAndConvert(interp, buf, NULL, NULL) != TCL_OK) + || ((*dash != '\0') + && (CheckVersionAndConvert(interp, dash, NULL, NULL) != TCL_OK))) { + ckfree(buf); return TCL_ERROR; } - free (buf); + ckfree(buf); return TCL_OK; -#endif } -#ifdef TCL_TIP268 /* *---------------------------------------------------------------------- @@ -2104,13 +1889,21 @@ CheckRequirement(interp, string) static void AddRequirementsToResult(interp, reqc, reqv) Tcl_Interp* interp; - int reqc; /* Requirements constraining the desired version. */ - Tcl_Obj *CONST reqv[]; /* 0 means to use the latest version available. */ + int reqc; /* Requirements constraining the desired version. */ + Tcl_Obj *CONST reqv[]; /* 0 means use the latest version available. */ { if (reqc > 0) { int i; for (i = 0; i < reqc; i++) { - Tcl_AppendResult(interp, " ", TclGetString(reqv[i]), NULL); + int length; + char *v = Tcl_GetStringFromObj(reqv[i], &length); + + if ((length & 0x1) && (v[length/2] == '-') + && (strncmp(v, v+((length+1)/2), length/2) == 0)) { + Tcl_AppendResult(interp, " ", v+((length+1)/2), NULL); + } else { + Tcl_AppendResult(interp, " ", v, NULL); + } } } } @@ -2134,8 +1927,8 @@ AddRequirementsToResult(interp, reqc, reqv) static void AddRequirementsToDString(dstring, reqc, reqv) Tcl_DString* dstring; - int reqc; /* Requirements constraining the desired version. */ - Tcl_Obj *CONST reqv[]; /* 0 means to use the latest version available. */ + int reqc; /* Requirements constraining the desired version. */ + Tcl_Obj *CONST reqv[]; /* 0 means use the latest version available. */ { if (reqc > 0) { int i; @@ -2151,7 +1944,7 @@ AddRequirementsToDString(dstring, reqc, reqv) /* *---------------------------------------------------------------------- * - * AllRequirementSatisfied -- + * SomeRequirementSatisfied -- * * This function checks to see whether a version satisfies at * least one of a set of requirements. @@ -2169,18 +1962,21 @@ AddRequirementsToDString(dstring, reqc, reqv) */ static int -AllRequirementsSatisfied(availVersionI, reqc, reqv) - CONST 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(availVersionI, reqc, reqv) + char *availVersionI; /* Candidate version to check against the + * requirements. */ + int reqc; /* Requirements constraining the desired + * version. */ + Tcl_Obj *CONST reqv[]; /* 0 means 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, Tcl_GetString(reqv[i]))) { + return 1; + } } - return satisfies; + return 0; } /* @@ -2204,7 +2000,7 @@ AllRequirementsSatisfied(availVersionI, reqc, reqv) static int RequirementSatisfied(havei, req) - CONST char *havei; /* Version string, of candidate package we have */ + 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. */ @@ -2226,9 +2022,9 @@ RequirementSatisfied(havei, req) CheckVersionAndConvert (NULL, req, &reqi, NULL); strcat (reqi, " -2"); - res = CompareVersions(havei, reqi, &thisIsMajor); + res = CompareVersions(havei, reqi, &thisIsMajor); satisfied = (res == 0) || ((res == 1) && !thisIsMajor); - Tcl_Free (reqi); + ckfree(reqi); return satisfied; } @@ -2237,7 +2033,7 @@ RequirementSatisfied(havei, req) * versions. Note that the max part can be empty. */ - buf = strdup (req); + DupString(buf, req); dash = buf + (dash - req); *dash = '\0'; /* buf now <=> min part */ dash ++; /* dash now <=> max part */ @@ -2252,8 +2048,8 @@ RequirementSatisfied(havei, req) 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; } @@ -2274,127 +2070,13 @@ RequirementSatisfied(havei, req) (CompareVersions(havei, max, NULL) < 0)); } - Tcl_Free (min); - Tcl_Free (max); - free (buf); + ckfree(min); + ckfree(max); + ckfree(buf); return satisfied; } /* - *---------------------------------------------------------------------- - * - * ExactRequirement -- - * - * 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. - * - * Results: - * A Tcl_Obj containing the version range as string. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static Tcl_Obj* -ExactRequirement(version) - CONST char* version; -{ - /* 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; - int lc, i; - CONST char** lv; - char buf [30]; - Tcl_Obj* o = Tcl_NewStringObj (version,-1); - Tcl_AppendStringsToObj (o, "-", NULL); - - /* 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); - } else { - Tcl_AppendStringsToObj (o, ".", NULL); - } - } - /* Regular component, last */ - sprintf (buf, "%d", atoi (lv [lc-1]) + 1); - Tcl_AppendStringsToObj (o, buf, NULL); - - ckfree ((char*) lv); - return o; -} - -/* - *---------------------------------------------------------------------- - * - * 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 * c-basic-offset: 4 diff --git a/tests/pkg.test b/tests/pkg.test index 27902a9..c363e24 100644 --- a/tests/pkg.test +++ b/tests/pkg.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: pkg.test,v 1.9.12.10 2007/02/22 20:25:29 andreas_kupries Exp $ +# RCS: @(#) $Id: pkg.test,v 1.9.12.11 2007/09/19 09:23:59 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -154,7 +154,7 @@ test pkg-2.8-268 {Tcl_PkgRequire procedure, can't find suitable version} tip268 } list [catch {package require -exact t 1.3} msg] $msg -} {1 {can't find package t 1.3-1.4}} +} {1 {can't find package t 1.3}} test pkg-2.9 {Tcl_PkgRequire procedure, can't find suitable version} { package forget t package unknown {} @@ -217,7 +217,7 @@ test pkg-2.13-268 {Tcl_PkgRequire procedure, "package unknown" support} tip268 { package require -exact t 1.5 package unknown {} set x -} {t 1.5-1.6} +} {t 1.5-1.5} test pkg-2.14 {Tcl_PkgRequire procedure, "package unknown" support} { proc pkgUnknown args { @@ -321,7 +321,7 @@ test pkg-2.17-268 {Tcl_PkgRequire procedure, "package unknown" doesn't load pack set result [list [catch {package require -exact t 1.5} msg] $msg $x] package unknown {} set result -} {1 {can't find package t 1.5-1.6} {t 1.5-1.6}} +} {1 {can't find package t 1.5} {t 1.5-1.5}} test pkg-2.18 {Tcl_PkgRequire procedure, version checks} { package forget t package provide t 2.3 @@ -361,7 +361,7 @@ test pkg-2.24-268 {Tcl_PkgRequire procedure, version checks} tip268 { package forget t package provide t 2.3 list [catch {package require -exact t 2.2} msg] $msg -} {1 {version conflict for package "t": have 2.3, need 2.2-2.3}} +} {1 {version conflict for package "t": have 2.3, need 2.2}} test pkg-2.25 {Tcl_PkgRequire procedure, error in ifneeded script} -body { package forget t package ifneeded t 2.1 {package provide t 2.1; error "ifneeded test" EI} @@ -987,16 +987,16 @@ test pkg-7.10 {Tcl_PkgPresent procedure, unknown package} { package forget t list [catch {package present -exact t 2.4} msg] $msg } {1 {package t 2.4 is not present}} -test pkg-7.11 {Tcl_PackageCmd procedure, "present" option} { +test pkg-7.11 {Tcl_PackageCmd procedure, "present" option} !tip268 { list [catch {package present} msg] $msg } {1 {wrong # args: should be "package present ?-exact? package ?version?"}} -test pkg-7.12 {Tcl_PackageCmd procedure, "present" option} { +test pkg-7.12 {Tcl_PackageCmd procedure, "present" option} !tip268 { list [catch {package present a b c} msg] $msg } {1 {wrong # args: should be "package present ?-exact? package ?version?"}} -test pkg-7.13 {Tcl_PackageCmd procedure, "present" option} { +test pkg-7.13 {Tcl_PackageCmd procedure, "present" option} !tip268 { list [catch {package present -exact a b c} msg] $msg } {1 {wrong # args: should be "package present ?-exact? package ?version?"}} -test pkg-7.14 {Tcl_PackageCmd procedure, "present" option} { +test pkg-7.14 {Tcl_PackageCmd procedure, "present" option} !tip268 { list [catch {package present -bs a b} msg] $msg } {1 {wrong # args: should be "package present ?-exact? package ?version?"}} test pkg-7.15 {Tcl_PackageCmd procedure, "present" option} { @@ -1005,10 +1005,10 @@ test pkg-7.15 {Tcl_PackageCmd procedure, "present" option} { test pkg-7.16 {Tcl_PackageCmd procedure, "present" option} { list [catch {package present -exact x a.b} msg] $msg } {1 {expected version number but got "a.b"}} -test pkg-7.17 {Tcl_PackageCmd procedure, "present" option} { +test pkg-7.17 {Tcl_PackageCmd procedure, "present" option} !tip268 { list [catch {package present -exact x} msg] $msg } {1 {wrong # args: should be "package present ?-exact? package ?version?"}} -test pkg-7.18 {Tcl_PackageCmd procedure, "present" option} { +test pkg-7.18 {Tcl_PackageCmd procedure, "present" option} !tip268 { list [catch {package present -exact} msg] $msg } {1 {wrong # args: should be "package present ?-exact? package ?version?"}} |