diff options
Diffstat (limited to 'generic')
| -rw-r--r-- | generic/tcl.decls | 19 | ||||
| -rw-r--r-- | generic/tclBasic.c | 11 | ||||
| -rw-r--r-- | generic/tclConfig.c | 12 | ||||
| -rw-r--r-- | generic/tclDecls.h | 15 | ||||
| -rw-r--r-- | generic/tclInt.h | 20 | ||||
| -rw-r--r-- | generic/tclPkg.c | 987 | ||||
| -rw-r--r-- | generic/tclStubInit.c | 3 | ||||
| -rw-r--r-- | generic/tclTest.c | 6 | ||||
| -rw-r--r-- | generic/tclTomMathInterface.c | 6 |
9 files changed, 930 insertions, 149 deletions
diff --git a/generic/tcl.decls b/generic/tcl.decls index e19db3f..189bcaf 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: tcl.decls,v 1.120 2006/02/08 21:41:27 dgp Exp $ +# RCS: @(#) $Id: tcl.decls,v 1.121 2006/09/22 18:13:27 andreas_kupries Exp $ library tcl @@ -971,6 +971,7 @@ declare 273 generic { int Tcl_PkgProvide(Tcl_Interp *interp, CONST char *name, CONST char *version) } +# TIP #268: The internally used new Require function is in slot 573. declare 274 generic { CONST84_RETURN char * Tcl_PkgRequire(Tcl_Interp *interp, CONST char *name, CONST char *version, int exact) @@ -1989,7 +1990,7 @@ declare 554 generic { Tcl_DriverThreadActionProc *Tcl_ChannelThreadActionProc(Tcl_ChannelType *chanTypePtr) } -# TIP #237: +# TIP#237 (Arbitrary-precision Integers) kevin kenny declare 555 generic { Tcl_Obj* Tcl_NewBignumObj( mp_int* value ) @@ -2007,7 +2008,7 @@ declare 559 generic { int Tcl_GetBignumAndClearObj( Tcl_Interp* interp, Tcl_Obj* obj, mp_int* value ) } -# TIP #208: +# TIP #208 ('chan' Command) jeffh declare 560 generic { int Tcl_TruncateChannel(Tcl_Channel chan, Tcl_WideInt length) } @@ -2031,14 +2032,14 @@ declare 565 generic { void Tcl_GetChannelError (Tcl_Channel chan, Tcl_Obj** msg) } -# Additional conversion functions for bignum support +# TIP #237 (Additional conversion functions for bignum support) declare 566 generic { int Tcl_InitBignumFromDouble(Tcl_Interp* interp, double initval, mp_int *toInit) } -# TIP 181 +# TIP#181 (namespace unknown Command) declare 567 generic { Tcl_Obj *Tcl_GetNamespaceUnknownHandler(Tcl_Interp *interp, Tcl_Namespace *nsPtr) @@ -2049,7 +2050,7 @@ declare 568 generic { Tcl_Obj *handlerPtr) } -# TIP#258 Enhanced Interface for Encodings +# TIP#258 (Enhanced Interface for Encodings) declare 569 generic { int Tcl_GetEncodingFromObj(Tcl_Interp* interp, Tcl_Obj* objPtr, @@ -2065,6 +2066,12 @@ declare 572 generic { CONST char *Tcl_GetEncodingNameFromEnvironment(Tcl_DString* bufPtr) } +# TIP#268: Extended version numbers and requirements +declare 573 generic { + int Tcl_PkgRequireProc(Tcl_Interp *interp, CONST char *name, + int objc, Tcl_Obj *CONST objv[], ClientData *clientDataPtr) +} + ############################################################################## # Define the platform specific public Tcl interface. These functions are diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 1c3eb2c..c931281 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.196 2006/08/30 19:33:11 hobbs Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.197 2006/09/22 18:13:27 andreas_kupries Exp $ */ #include "tclInt.h" @@ -326,6 +326,12 @@ Tcl_CreateInterp(void) Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS); iPtr->packageUnknown = NULL; + + /* TIP #268 */ + iPtr->packagePrefer = (getenv ("TCL_PKG_PREFER_LATEST") == NULL ? + PKG_PREFER_STABLE : + PKG_PREFER_LATEST); + iPtr->cmdCount = 0; TclInitLiteralTable(&(iPtr->literalTable)); iPtr->compileEpoch = 0; @@ -562,9 +568,10 @@ Tcl_CreateInterp(void) /* * Register Tcl's version number. + * TIP #268: Full patchlevel instead of just major.minor */ - Tcl_PkgProvideEx(interp, "Tcl", TCL_VERSION, (ClientData) &tclStubs); + Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, (ClientData) &tclStubs); #ifdef Tcl_InitStubs #undef Tcl_InitStubs diff --git a/generic/tclConfig.c b/generic/tclConfig.c index 756b396..c65c501 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclConfig.c,v 1.10 2005/11/01 15:30:52 dkf Exp $ + * RCS: @(#) $Id: tclConfig.c,v 1.11 2006/09/22 18:13:28 andreas_kupries Exp $ */ #include "tclInt.h" @@ -68,14 +68,18 @@ Tcl_RegisterConfig( CONST char *valEncoding) /* Name of the encoding used to store the * configuration values, ASCII, thus UTF-8. */ { - Tcl_Encoding venc = Tcl_GetEncoding(NULL, valEncoding); - Tcl_Obj *pDB = GetConfigDict(interp); - Tcl_Obj *pkg = Tcl_NewStringObj(pkgName, -1); + Tcl_Encoding venc; + Tcl_Obj *pDB; + Tcl_Obj *pkg; Tcl_Obj *pkgDict; Tcl_DString cmdName; Tcl_Config *cfg; int res; + venc = Tcl_GetEncoding(NULL, valEncoding); + pDB = GetConfigDict(interp); + pkg = Tcl_NewStringObj(pkgName, -1); + /* * Phase I: Adding the provided information to the internal database of * package meta data. diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 00f009f..35776db 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclDecls.h,v 1.122 2006/02/08 21:41:27 dgp Exp $ + * RCS: @(#) $Id: tclDecls.h,v 1.123 2006/09/22 18:13:28 andreas_kupries Exp $ */ #ifndef _TCLDECLS @@ -3571,6 +3571,14 @@ EXTERN int Tcl_SetEncodingSearchPath _ANSI_ARGS_(( EXTERN CONST char * Tcl_GetEncodingNameFromEnvironment _ANSI_ARGS_(( Tcl_DString* bufPtr)); #endif +#ifndef Tcl_PkgRequireProc_TCL_DECLARED +#define Tcl_PkgRequireProc_TCL_DECLARED +/* 573 */ +EXTERN int Tcl_PkgRequireProc _ANSI_ARGS_((Tcl_Interp * interp, + CONST char * name, int objc, + Tcl_Obj *CONST objv[], + ClientData * clientDataPtr)); +#endif typedef struct TclStubHooks { struct TclPlatStubs *tclPlatStubs; @@ -4185,6 +4193,7 @@ typedef struct TclStubs { Tcl_Obj* (*tcl_GetEncodingSearchPath) _ANSI_ARGS_((void)); /* 570 */ int (*tcl_SetEncodingSearchPath) _ANSI_ARGS_((Tcl_Obj* searchPath)); /* 571 */ CONST char * (*tcl_GetEncodingNameFromEnvironment) _ANSI_ARGS_((Tcl_DString* bufPtr)); /* 572 */ + int (*tcl_PkgRequireProc) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, int objc, Tcl_Obj *CONST objv[], ClientData * clientDataPtr)); /* 573 */ } TclStubs; #ifdef __cplusplus @@ -6517,6 +6526,10 @@ extern TclStubs *tclStubsPtr; #define Tcl_GetEncodingNameFromEnvironment \ (tclStubsPtr->tcl_GetEncodingNameFromEnvironment) /* 572 */ #endif +#ifndef Tcl_PkgRequireProc +#define Tcl_PkgRequireProc \ + (tclStubsPtr->tcl_PkgRequireProc) /* 573 */ +#endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclInt.h b/generic/tclInt.h index 0f34ea5..7b230dc 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.275 2006/08/21 01:08:41 das Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.276 2006/09/22 18:13:28 andreas_kupries Exp $ */ #ifndef _TCLINT @@ -1260,6 +1260,15 @@ typedef struct ResolverScheme { typedef struct LimitHandler LimitHandler; /* + * TIP #268. + * Values for the selection mode, i.e the package require preferences. + */ + +enum PkgPreferOptions { + PKG_PREFER_LATEST, PKG_PREFER_STABLE +}; + +/* *---------------------------------------------------------------- * This structure defines an interpreter, which is a collection of commands * plus other state information related to interpreting commands, such as @@ -1376,6 +1385,15 @@ typedef struct Interp { * NULL. */ /* + * TIP #268. + * The currently active selection mode, + * i.e the package require preferences. + */ + + int packagePrefer; /* Current package selection mode. + */ + + /* * Miscellaneous information: */ diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 9a990a2..0ff2b7c 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -5,11 +5,16 @@ * "package" command and a few C APIs. * * Copyright (c) 1996 Sun Microsystems, Inc. + * Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> * * 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.15 2006/08/30 17:59:03 hobbs Exp $ + * RCS: @(#) $Id: tclPkg.c,v 1.16 2006/09/22 18:13:28 andreas_kupries Exp $ + * + * TIP #268. + * Heavily rewritten to handle the extend version numbers, and extended + * package requirements. */ #include "tclInt.h" @@ -50,10 +55,25 @@ typedef struct Package { * Prototypes for functions defined in this file: */ -static int CheckVersion(Tcl_Interp *interp, CONST char *string); -static int ComparePkgVersions(CONST char *v1, CONST char *v2, - int *satPtr); +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[]); +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); /* *---------------------------------------------------------------------- @@ -96,6 +116,9 @@ Tcl_PkgProvideEx( * for C callback function table) */ { Package *pkgPtr; + char* pvi; + char* vi; + int res; pkgPtr = FindPackage(interp, name); if (pkgPtr->version == NULL) { @@ -104,7 +127,19 @@ Tcl_PkgProvideEx( pkgPtr->clientData = clientData; return TCL_OK; } - if (ComparePkgVersions(pkgPtr->version, version, NULL) == 0) { + + if (CheckVersionAndConvert (interp, pkgPtr->version, &pvi, NULL) != TCL_OK) { + return TCL_ERROR; + } else if (CheckVersionAndConvert (interp, version, &vi, NULL) != TCL_OK) { + Tcl_Free (pvi); + return TCL_ERROR; + } + + res = CompareVersions(pvi, vi, NULL); + Tcl_Free (pvi); + Tcl_Free (vi); + + if (res == 0) { if (clientData != NULL) { pkgPtr->clientData = clientData; } @@ -118,7 +153,7 @@ Tcl_PkgProvideEx( /* *---------------------------------------------------------------------- * - * Tcl_PkgRequire / Tcl_PkgRequireEx -- + * Tcl_PkgRequire / Tcl_PkgRequireEx / Tcl_PkgRequireProc -- * * This function is called by code that depends on a particular version * of a particular package. If the package is not already provided in the @@ -171,11 +206,8 @@ Tcl_PkgRequireEx( * is not returned. This is unchanged if this * call fails for any reason. */ { - Package *pkgPtr; - PkgAvail *availPtr, *bestPtr; - char *script; - int code, satisfies, result, pass; - Tcl_DString command; + Tcl_Obj *ov; + int res; /* * If an attempt is being made to load this into a standalone executable @@ -248,6 +280,69 @@ Tcl_PkgRequireEx( return NULL; } + /* Translate between old and new API, and defer to the new function. */ + + if (exact) { + ov = ExactRequirement (version); + } else { + ov = Tcl_NewStringObj (version,-1); + } + + Tcl_IncrRefCount (ov); + res = Tcl_PkgRequireProc(interp, name, 1, &ov, clientDataPtr); + Tcl_DecrRefCount (ov); + + if (res != TCL_OK) { + return NULL; + } + + /* 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. + */ + + ov = (Tcl_Obj*) Tcl_GetAssocData (interp, "tcl/Tcl_PkgRequireEx", NULL); + if (ov != NULL) { + Tcl_DecrRefCount (ov); + } + + ov = Tcl_GetObjResult (interp); + Tcl_IncrRefCount (ov); + Tcl_SetAssocData(interp, "tcl/Tcl_PkgRequireEx", VersionCleanupProc, + (ClientData) ov); + Tcl_ResetResult (interp); + + return Tcl_GetString (ov); +} + +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) +{ + 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; + Tcl_DString command; + char* pkgVersionI; + /* * It can take up to three passes to find the package: one pass to run the * "package unknown" script, one to run the "package ifneeded" script for @@ -270,36 +365,85 @@ Tcl_PkgRequireEx( Tcl_AppendResult(interp, "circular package dependency: ", "attempt to provide ", name, " ", (char *)(pkgPtr->clientData), " requires ", name, NULL); - if (version != NULL) { - Tcl_AppendResult(interp, " ", version, NULL); - } - return NULL; + AddRequirementsToResult (interp, reqc, reqv); + return TCL_ERROR; } /* * The package isn't yet present. Search the list of available * versions and invoke the script for the best available version. + * We are actually locating the best, and the best stable version. + * One of them is then chosen based on the selection mode. */ - bestPtr = NULL; - for (availPtr = pkgPtr->availPtr; availPtr != NULL; - availPtr = availPtr->nextPtr) { - if ((bestPtr != NULL) && (ComparePkgVersions(availPtr->version, - bestPtr->version, NULL) <= 0)) { + 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 + * should not happen. This should have been caught by the + * 'package ifneeded' registering the package. + */ + continue; } - if (version != NULL) { - result = ComparePkgVersions(availPtr->version, version, - &satisfies); - if ((result != 0) && exact) { + + 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); + availVersion = NULL; continue; } + } + + /* We have found a version which is better than our max. */ + + if (reqc > 0) { + /* Check satisfaction of requirements */ + satisfies = AllRequirementsSatisfied (availVersion, reqc, reqv); if (!satisfies) { + Tcl_Free (availVersion); + availVersion = NULL; continue; } } + bestPtr = availPtr; + + if (bestVersion != NULL) Tcl_Free (bestVersion); + bestVersion = availVersion; + + /* If this new best version is stable then it also has to be + * better than the max stable version found so far. + */ + + if (availStable) { + bestStablePtr = availPtr; + } + } + + if (bestVersion != NULL) { + Tcl_Free (bestVersion); + } + + /* Now choose a version among the two best. For 'latest' we simply + * take (actually keep) the best. For 'stable' we take the best + * stable, if there is any, or the best if there is nothing stable. + */ + + if ((iPtr->packagePrefer == PKG_PREFER_STABLE) && (bestStablePtr != NULL)) { + bestPtr = bestStablePtr; } + if (bestPtr != NULL) { /* * We found an ifneeded script for the package. Be careful while @@ -309,7 +453,7 @@ Tcl_PkgRequireEx( */ CONST char *versionToProvide = bestPtr->version; script = bestPtr->script; - + pkgPtr->clientData = (ClientData) versionToProvide; Tcl_Preserve((ClientData) script); Tcl_Preserve((ClientData) versionToProvide); @@ -325,13 +469,29 @@ Tcl_PkgRequireEx( name, " ", versionToProvide, " failed: no version of package ", name, " provided", NULL); - } else if (0 != ComparePkgVersions( - pkgPtr->version, versionToProvide, NULL)) { - code = TCL_ERROR; - Tcl_AppendResult(interp, "attempt to provide package ", - name, " ", versionToProvide, " failed: package ", - name, " ", pkgPtr->version, " provided instead", - NULL); + } else { + char* pvi; + char* vi; + int res; + + if (CheckVersionAndConvert (interp, pkgPtr->version, &pvi, NULL) != TCL_OK) { + code = TCL_ERROR; + } else if (CheckVersionAndConvert (interp, versionToProvide, &vi, NULL) != TCL_OK) { + Tcl_Free (pvi); + code = TCL_ERROR; + } else { + res = CompareVersions(pvi, vi, NULL); + Tcl_Free (pvi); + Tcl_Free (vi); + + if (res != 0) { + code = TCL_ERROR; + Tcl_AppendResult(interp, "attempt to provide package ", + name, " ", versionToProvide, " failed: package ", + name, " ", pkgPtr->version, " provided instead", + NULL); + } + } } } else if (code != TCL_ERROR) { Tcl_Obj *codePtr = Tcl_NewIntObj(code); @@ -367,13 +527,14 @@ Tcl_PkgRequireEx( pkgPtr->version = NULL; } pkgPtr->clientData = NULL; - return NULL; + return TCL_ERROR; } + break; } /* - * Package not in the database. If there is a "package unknown" + * The package is not in the database. If there is a "package unknown" * command, invoke it (but only on the first pass; after that, we * should not get here in the first place). */ @@ -381,17 +542,14 @@ Tcl_PkgRequireEx( if (pass > 1) { break; } + script = ((Interp *) interp)->packageUnknown; if (script != NULL) { Tcl_DStringInit(&command); Tcl_DStringAppend(&command, script, -1); Tcl_DStringAppendElement(&command, name); - Tcl_DStringAppend(&command, " ", 1); - Tcl_DStringAppend(&command, (version != NULL) ? version : "{}", - -1); - if (exact) { - Tcl_DStringAppend(&command, " -exact", 7); - } + AddRequirementsToDString(&command, reqc, reqv); + code = Tcl_EvalEx(interp, Tcl_DStringValue(&command), Tcl_DStringLength(&command), TCL_EVAL_GLOBAL); Tcl_DStringFree(&command); @@ -406,7 +564,7 @@ Tcl_PkgRequireEx( } if (code == TCL_ERROR) { Tcl_AddErrorInfo(interp, "\n (\"package unknown\" script)"); - return NULL; + return TCL_ERROR; } Tcl_ResetResult(interp); } @@ -414,38 +572,41 @@ Tcl_PkgRequireEx( if (pkgPtr->version == NULL) { Tcl_AppendResult(interp, "can't find package ", name, NULL); - if (version != NULL) { - Tcl_AppendResult(interp, " ", version, NULL); - } - return NULL; + AddRequirementsToResult(interp, reqc, reqv); + return TCL_ERROR; } /* * At this point we know that the package is present. Make sure that the - * provided version meets the current requirement. + * provided version meets the current requirements. */ - if (version == NULL) { - if (clientDataPtr) { - *clientDataPtr = pkgPtr->clientData; - } - return pkgPtr->version; + if (reqc == 0) { + satisfies = 1; + } else { + CheckVersionAndConvert (interp, pkgPtr->version, &pkgVersionI, NULL); + satisfies = AllRequirementsSatisfied (pkgVersionI, reqc, reqv); + + Tcl_Free (pkgVersionI); } - result = ComparePkgVersions(pkgPtr->version, version, &satisfies); - if ((satisfies && !exact) || (result == 0)) { + + if (satisfies) { if (clientDataPtr) { *clientDataPtr = pkgPtr->clientData; } - return pkgPtr->version; + Tcl_SetObjResult (interp, Tcl_NewStringObj (pkgPtr->version, -1)); + return TCL_OK; } + Tcl_AppendResult(interp, "version conflict for package \"", - name, "\": have ", pkgPtr->version, ", need ", version, NULL); - return NULL; + name, "\": have ", pkgPtr->version, ", need", NULL); + AddRequirementsToResult (interp, reqc, reqv); + return TCL_ERROR; } /* *---------------------------------------------------------------------- - *q + * * Tcl_PkgPresent / Tcl_PkgPresentEx -- * * Checks to see whether the specified package is present. If it is not @@ -502,6 +663,10 @@ Tcl_PkgPresentEx( if (hPtr) { pkgPtr = (Package *) 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. @@ -514,7 +679,20 @@ Tcl_PkgPresentEx( return pkgPtr->version; } - result = ComparePkgVersions(pkgPtr->version, version, &satisfies); + + 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); + if ((satisfies && !exact) || (result == 0)) { if (clientDataPtr) { *clientDataPtr = pkgPtr->clientData; @@ -563,13 +741,14 @@ Tcl_PackageObjCmd( Tcl_Obj *CONST objv[]) /* Argument objects. */ { static CONST char *pkgOptions[] = { - "forget", "ifneeded", "names", "present", "provide", "require", - "unknown", "vcompare", "versions", "vsatisfies", NULL + "forget", "ifneeded", "names", "prefer", "present", + "provide", "require", "unknown", "vcompare", "versions", + "vsatisfies", NULL }; enum pkgOptions { - PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, PKG_PRESENT, - PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE, - PKG_VERSIONS, PKG_VSATISFIES + PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, PKG_PREFER, PKG_PRESENT, + PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE, PKG_VERSIONS, + PKG_VSATISFIES }; Interp *iPtr = (Interp *) interp; int optionIndex, exact, i, satisfies; @@ -580,6 +759,8 @@ Tcl_PackageObjCmd( Tcl_HashTable *tablePtr; CONST char *version; char *argv2, *argv3, *argv4; + char* iva = NULL; + char* ivb = NULL; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); @@ -618,19 +799,23 @@ Tcl_PackageObjCmd( } case PKG_IFNEEDED: { int length; + char* argv3i; + char* avi; + int res; if ((objc != 4) && (objc != 5)) { Tcl_WrongNumArgs(interp, 2, objv, "package version ?script?"); return TCL_ERROR; } argv3 = Tcl_GetString(objv[3]); - if (CheckVersion(interp, argv3) != TCL_OK) { + if (CheckVersionAndConvert(interp, argv3, &argv3i, NULL) != TCL_OK) { return TCL_ERROR; } argv2 = Tcl_GetString(objv[2]); if (objc == 4) { hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); if (hPtr == NULL) { + Tcl_Free (argv3i); return TCL_OK; } pkgPtr = (Package *) Tcl_GetHashValue(hPtr); @@ -638,10 +823,22 @@ Tcl_PackageObjCmd( 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, NULL) == 0){ + + 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); + return TCL_ERROR; + } + + res = CompareVersions(avi, argv3i, NULL); + Tcl_Free (avi); + + if (res == 0){ if (objc == 4) { + Tcl_Free (argv3i); Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE); return TCL_OK; } @@ -649,6 +846,8 @@ Tcl_PackageObjCmd( break; } } + Tcl_Free (argv3i); + if (objc == 4) { return TCL_OK; } @@ -656,6 +855,7 @@ Tcl_PackageObjCmd( 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; @@ -698,7 +898,7 @@ Tcl_PackageObjCmd( version = NULL; if (objc == (4 + exact)) { version = Tcl_GetString(objv[3 + exact]); - if (CheckVersion(interp, version) != TCL_OK) { + if (CheckVersionAndConvert(interp, version, NULL, NULL) != TCL_OK) { return TCL_ERROR; } } else if ((objc != 3) || exact) { @@ -732,41 +932,50 @@ Tcl_PackageObjCmd( return TCL_OK; } argv3 = Tcl_GetString(objv[3]); - if (CheckVersion(interp, argv3) != TCL_OK) { + if (CheckVersionAndConvert(interp, argv3, NULL, NULL) != TCL_OK) { return TCL_ERROR; } return Tcl_PkgProvide(interp, argv2, argv3); case PKG_REQUIRE: if (objc < 3) { requireSyntax: - Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?"); + Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?requirement...?"); return TCL_ERROR; } + + version = NULL; + 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) { + Tcl_Obj* ov; + int res; + + if (objc != 5) { + goto requireSyntax; + } + + version = Tcl_GetString(objv[4]); + if (CheckVersionAndConvert(interp, version, NULL, NULL) != 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); + + /* Create a new-style requirement for the exact version. */ + + ov = ExactRequirement (version); + version = NULL; + argv3 = Tcl_GetString(objv[3]); + + Tcl_IncrRefCount (ov); + res = Tcl_PkgRequireProc(interp, argv3, 1, &ov, NULL); + Tcl_DecrRefCount (ov); + return res; } else { - version = Tcl_PkgRequire(interp, argv2, version, exact); - } - if (version == NULL) { - return TCL_ERROR; + if (CheckAllRequirements (interp, objc-3, objv+3) != TCL_OK) { + return TCL_ERROR; + } + + return Tcl_PkgRequireProc(interp, argv2, objc-3, objv+3, NULL); } - Tcl_SetObjResult(interp, Tcl_NewStringObj(version, -1)); break; case PKG_UNKNOWN: { int length; @@ -792,6 +1001,34 @@ Tcl_PackageObjCmd( } break; } + case PKG_PREFER: { + /* See tclInt.h for the enum, just before Interp */ + static CONST char *pkgPreferOptions[] = { + "latest", "stable", NULL + }; + + if (objc > 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?latest|stable?"); + return TCL_ERROR; + } + + if (objc == 3) { + /* Set value. */ + + int new; + if (Tcl_GetIndexFromObj(interp, objv[2], pkgPreferOptions, "preference", 0, + &new) != TCL_OK) { + return TCL_ERROR; + } + + if (new < iPtr->packagePrefer) { + iPtr->packagePrefer = new; + } + } + /* Always return current value. */ + Tcl_SetObjResult(interp, Tcl_NewStringObj (pkgPreferOptions [iPtr->packagePrefer], -1)); + break; + } case PKG_VCOMPARE: if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "version1 version2"); @@ -799,12 +1036,17 @@ Tcl_PackageObjCmd( } argv3 = Tcl_GetString(objv[3]); argv2 = Tcl_GetString(objv[2]); - if ((CheckVersion(interp, argv2) != TCL_OK) - || (CheckVersion(interp, argv3) != TCL_OK)) { + 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 */ return TCL_ERROR; } - Tcl_SetObjResult(interp, - Tcl_NewIntObj(ComparePkgVersions(argv2, argv3, NULL))); + + /* Comparison is done on the internal representation */ + Tcl_SetObjResult(interp,Tcl_NewIntObj(CompareVersions(iva, ivb, NULL))); + Tcl_Free (iva); + Tcl_Free (ivb); break; case PKG_VERSIONS: if (objc != 3) { @@ -821,20 +1063,28 @@ Tcl_PackageObjCmd( } } break; - case PKG_VSATISFIES: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "version1 version2"); + case PKG_VSATISFIES: { + char* argv2i = NULL; + + if (objc < 4) { + Tcl_WrongNumArgs(interp, 2, objv, "version requirement requirement..."); return TCL_ERROR; } - argv3 = Tcl_GetString(objv[3]); + argv2 = Tcl_GetString(objv[2]); - if ((CheckVersion(interp, argv2) != TCL_OK) - || (CheckVersion(interp, argv3) != TCL_OK)) { + if ((CheckVersionAndConvert(interp, argv2, &argv2i, NULL) != TCL_OK)) { + return TCL_ERROR; + } else if (CheckAllRequirements (interp, objc-3, objv+3) != TCL_OK) { + Tcl_Free (argv2i); return TCL_ERROR; } - ComparePkgVersions(argv2, argv3, &satisfies); + + satisfies = AllRequirementsSatisfied (argv2i, objc-3, objv+3); + Tcl_Free (argv2i); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(satisfies)); break; + } default: Tcl_Panic("Tcl_PackageObjCmd: bad option index to pkgOptions"); } @@ -932,9 +1182,11 @@ TclFreePackageInfo( /* *---------------------------------------------------------------------- * - * CheckVersion -- + * CheckVersionAndConvert -- * - * This function checks to see whether a version number has valid syntax. + * 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. @@ -948,30 +1200,82 @@ TclFreePackageInfo( */ static int -CheckVersion( - Tcl_Interp *interp, /* Used for error reporting. */ - CONST char *string) /* Supposedly a version number, which is - * groups of decimal digits separated by - * dots. */ +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. */ { CONST char *p = string; char prevChar; + int hasunstable = 0; + /* 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 = Tcl_Alloc (4+4*strlen(string)); + char* ip = ibuf; + + /* 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 '.' + * (3) s.a. + * (4) Only one of 'a' or 'b' may occur. + * (5) Neither 'a', nor 'b' may occur before or after a '.' + */ if (!isdigit(UCHAR(*p))) { /* INTL: digit */ goto error; } + + *ip++ = *p; + for (prevChar = *p, p++; *p != 0; p++) { - if (!isdigit(UCHAR(*p)) && - ((*p != '.') || (prevChar == '.'))) { /* INTL: digit */ + 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 */ goto error; } + + if ((*p == 'a') || (*p == 'b')) { hasunstable = 1 ; } + + /* 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. */ + + 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 != '.') { + if ((prevChar != '.') && (prevChar != 'a') && (prevChar != 'b')) { + *ip = '\0'; + if (internal != NULL) { + *internal = ibuf; + } else { + Tcl_Free (ibuf); + } + if (stable != NULL) { + *stable = !hasunstable; + } return TCL_OK; } error: + Tcl_Free (ibuf); Tcl_AppendResult(interp, "expected version number but got \"", string, "\"", NULL); return TCL_ERROR; @@ -980,9 +1284,9 @@ CheckVersion( /* *---------------------------------------------------------------------- * - * ComparePkgVersions -- + * CompareVersions -- * - * This function compares two version numbers. + * This function compares two version numbers (in internal rep). * * Results: * The return value is -1 if v1 is less than v2, 0 if the two version @@ -997,22 +1301,30 @@ CheckVersion( */ static int -ComparePkgVersions( - CONST char *v1, - CONST char *v2, /* Versions strings, of form 2.1.3 (any number - * of version numbers). */ - int *satPtr) /* If non-null, the word pointed to is filled - * in with a 0/1 value. 1 means v1 "satisfies" - * v2: v1 is greater than or equal to v2 and - * both version numbers have the same major - * number. */ +CompareVersions( + 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. */ { int thisIsMajor, n1, n2; + int res, flip; /* * Each iteration of the following loop processes one number from each - * string, terminated by a ".". If those numbers don't match then the + * 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. */ thisIsMajor = 1; @@ -1022,14 +1334,20 @@ ComparePkgVersions( */ n1 = n2 = 0; - while ((*v1 != 0) && (*v1 != '.')) { + flip = 0; + while ((*v1 != 0) && (*v1 != ' ')) { + if (*v1 == '-') {flip = 1 ; v1++ ; continue;} n1 = 10*n1 + (*v1 - '0'); v1++; } - while ((*v2 != 0) && (*v2 != '.')) { + if (flip) n1 = -n1; + flip = 0; + while ((*v2 != 0) && (*v2 != ' ')) { + if (*v2 == '-') {flip = 1; v2++ ; continue;} n2 = 10*n2 + (*v2 - '0'); v2++; } + if (flip) n2 = -n2; /* * Compare and go on to the next version number if the current numbers @@ -1049,15 +1367,424 @@ ComparePkgVersions( } thisIsMajor = 0; } - if (satPtr != NULL) { - *satPtr = (n1 == n2) || ((n1 > n2) && !thisIsMajor); - } + if (n1 > n2) { - return 1; + res = 1; } else if (n1 == n2) { - return 0; + res = 0; + } else { + res = -1; + } + + if (isMajorPtr != NULL) { + *isMajorPtr = thisIsMajor; + } + + return res; +} + +/* + *---------------------------------------------------------------------- + * + * CheckAllRequirements -- + * + * 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. + * + * Side effects: + * May modify the interpreter result. + * + *---------------------------------------------------------------------- + */ + +static int +CheckAllRequirements( + 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)) { + return TCL_ERROR; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * CheckRequirement -- + * + * This function checks to see whether a requirement has valid syntax. + * + * Results: + * If string is a properly formed requirement then TCL_OK is returned. + * Otherwise TCL_ERROR is returned and an error message is left in the + * interp's result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +CheckRequirement( + Tcl_Interp *interp, /* Used for error reporting. */ + CONST char *string) /* Supposedly a requirement. */ +{ + /* Syntax of requirement = version + * = version-version + * = version- + */ + + char* dash = NULL; + char* buf; + + dash = strchr (string, '-'); + if (dash == 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); + return TCL_ERROR; + } + + /* Exactly one dash is present. Copy the string, split at the location of + * dash and check that both parts are versions. Note that the max part can + * be empty. + */ + + buf = strdup (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); + return TCL_ERROR; + } + + free (buf); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * AddRequirementsToResult -- + * + * This function accumulates requirements in the interpreter result. + * + * Results: + * None. + * + * Side effects: + * The interpreter result is extended. + * + *---------------------------------------------------------------------- + */ + +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. */ +{ + if (reqc > 0) { + int i; + for (i = 0; i < reqc; i++) { + Tcl_AppendResult(interp, " ", TclGetString(reqv[i]), NULL); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * AddRequirementsToDString -- + * + * This function accumulates requirements in a DString. + * + * Results: + * None. + * + * Side effects: + * The DString argument is extended. + * + *---------------------------------------------------------------------- + */ + +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. */ +{ + if (reqc > 0) { + int i; + for (i = 0; i < reqc; i++) { + Tcl_DStringAppend(dstring, " ", 1); + Tcl_DStringAppend(dstring, TclGetString(reqv[i]), -1); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * AllRequirementSatisfied -- + * + * 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. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +AllRequirementsSatisfied( + 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. */ +{ + int i, satisfies; + + for (satisfies = i = 0; i < reqc; i++) { + satisfies = RequirementSatisfied(availVersionI, Tcl_GetString(reqv[i])); + if (satisfies) break; + } + return satisfies; +} + +/* + *---------------------------------------------------------------------- + * + * RequirementSatisfied -- + * + * 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. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +RequirementSatisfied( + CONST 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. */ + + int satisfied, res; + char* dash = NULL; + char* buf, *min, *max; + + 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 + * 'a0', i.e '-2' before doing the comparison to properly accept + * unstables as well. + */ + + char* reqi = NULL; + int thisIsMajor; + + CheckVersionAndConvert (NULL, req, &reqi, NULL); + strcat (reqi, " -2"); + res = CompareVersions(havei, reqi, &thisIsMajor); + satisfied = (res == 0) || ((res == 1) && !thisIsMajor); + Tcl_Free (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. + */ + + buf = strdup (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 + * internal rep, padded with 'a0' i.e. '-2'. + */ + + /* No max part, unbound */ + + CheckVersionAndConvert (NULL, buf, &min, NULL); + strcat (min, " -2"); + satisfied = (CompareVersions(havei, min, NULL) >= 0); + Tcl_Free (min); + free (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. + */ + + CheckVersionAndConvert (NULL, buf, &min, NULL); + CheckVersionAndConvert (NULL, dash, &max, NULL); + + if (CompareVersions(min, max, NULL) == 0) { + satisfied = (CompareVersions(min, havei, NULL) == 0); } else { - return -1; + strcat (min, " -2"); + strcat (max, " -2"); + satisfied = ((CompareVersions(min, havei, NULL) <= 0) && + (CompareVersions(havei, max, NULL) < 0)); + } + + Tcl_Free (min); + Tcl_Free (max); + free (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); } } diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 9d52015..4a68100 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclStubInit.c,v 1.131 2006/06/21 03:10:39 dgp Exp $ + * RCS: @(#) $Id: tclStubInit.c,v 1.132 2006/09/22 18:13:29 andreas_kupries Exp $ */ #include "tclInt.h" @@ -1070,6 +1070,7 @@ TclStubs tclStubs = { Tcl_GetEncodingSearchPath, /* 570 */ Tcl_SetEncodingSearchPath, /* 571 */ Tcl_GetEncodingNameFromEnvironment, /* 572 */ + Tcl_PkgRequireProc, /* 573 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclTest.c b/generic/tclTest.c index d05e9f2..2e0f4ae 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTest.c,v 1.104 2006/06/21 20:44:59 das Exp $ + * RCS: @(#) $Id: tclTest.c,v 1.105 2006/09/22 18:13:29 andreas_kupries Exp $ */ #define TCL_TEST @@ -560,7 +560,9 @@ Tcltest_Init( "-appinitprocclosestderr", "-appinitprocsetrcfile", NULL }; - if (Tcl_PkgProvide(interp, "Tcltest", TCL_VERSION) == TCL_ERROR) { + /* TIP #268: Full patchlevel instead of just major.minor */ + + if (Tcl_PkgProvide(interp, "Tcltest", TCL_PATCH_LEVEL) == TCL_ERROR) { return TCL_ERROR; } diff --git a/generic/tclTomMathInterface.c b/generic/tclTomMathInterface.c index 65eddcf..f726531 100644 --- a/generic/tclTomMathInterface.c +++ b/generic/tclTomMathInterface.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTomMathInterface.c,v 1.6 2005/12/13 22:43:18 kennykb Exp $ + * RCS: @(#) $Id: tclTomMathInterface.c,v 1.7 2006/09/22 18:13:29 andreas_kupries Exp $ */ #include "tclInt.h" @@ -42,7 +42,9 @@ int TclTommath_Init( Tcl_Interp* interp /* Tcl interpreter */ ) { - if (Tcl_PkgProvideEx(interp, "tcl::tommath", TCL_VERSION, + /* TIP #268: Full patchlevel instead of just major.minor */ + + if (Tcl_PkgProvideEx(interp, "tcl::tommath", TCL_PATCH_LEVEL, (ClientData)&tclTomMathStubs) != TCL_OK) { return TCL_ERROR; } |