diff options
| -rw-r--r-- | ChangeLog | 16 | ||||
| -rw-r--r-- | doc/PkgRequire.3 | 4 | ||||
| -rw-r--r-- | generic/tcl.decls | 22 | ||||
| -rw-r--r-- | generic/tclBasic.c | 17 | ||||
| -rw-r--r-- | generic/tclDecls.h | 66 | ||||
| -rw-r--r-- | generic/tclInt.h | 22 | ||||
| -rw-r--r-- | generic/tclPkg.c | 1374 | ||||
| -rw-r--r-- | generic/tclStubInit.c | 21 | ||||
| -rw-r--r-- | generic/tclTest.c | 7 | ||||
| -rw-r--r-- | library/package.tcl | 108 | ||||
| -rw-r--r-- | tests/pkg.test | 472 | ||||
| -rw-r--r-- | tests/platform.test | 1 | ||||
| -rw-r--r-- | tests/safe.test | 6 |
13 files changed, 1993 insertions, 143 deletions
@@ -1,3 +1,19 @@ +2006-09-21 Andreas Kupries <andreask@activestate.com> + + * generic/tcl.decls: Implemented TIP #268, conditionally. + * generic/tclBasic.c: Define TCL_TIP268 to activate the new + * generic/tclDecls.h: features. + * generic/tclInt.h: + * generic/tclPkg.c: + * generic/tclStubInit.c: + * generic/tclTest.c: + * library/init.tcl + * library/package.tcl: + * tests/pkg.test: + * tests/platform.test: + * tests/safe.test: + * doc/PkgRequire.3: + 2006-09-15 Jeff Hobbs <jeffh@ActiveState.com> * library/http/http.tcl: Change " " -> "+" url encoding mapping diff --git a/doc/PkgRequire.3 b/doc/PkgRequire.3 index f16288a..d19f859 100644 --- a/doc/PkgRequire.3 +++ b/doc/PkgRequire.3 @@ -4,7 +4,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: PkgRequire.3,v 1.6 2002/02/26 02:22:20 hobbs Exp $ +'\" RCS: @(#) $Id: PkgRequire.3,v 1.6.2.1 2006/09/22 01:26:22 andreas_kupries Exp $ '\" .so man.macros .TH Tcl_PkgRequire 3 7.5 Tcl "Tcl Library Procedures" @@ -54,7 +54,6 @@ Pointer to place to store the value associated with the matching package. It is only changed if the pointer is not NULL and the function completed successfully. .BE - .SH DESCRIPTION .PP These procedures provide C-level interfaces to Tcl's package and @@ -82,6 +81,5 @@ in the interpreter's result. allow the setting and retrieving of the client data associated with the package. In all other respects they are equivalent to the matching functions. - .SH KEYWORDS package, present, provide, require, version diff --git a/generic/tcl.decls b/generic/tcl.decls index ed95c57..08a0e01 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.94.2.3 2005/01/27 22:53:28 andreas_kupries Exp $ +# RCS: @(#) $Id: tcl.decls,v 1.94.2.4 2006/09/22 01:26:22 andreas_kupries Exp $ library tcl @@ -971,6 +971,10 @@ 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. Assuming TCL_TIP268 was activated. + declare 274 generic { CONST84_RETURN char * Tcl_PkgRequire(Tcl_Interp *interp, CONST char *name, CONST char *version, int exact) @@ -1772,6 +1776,22 @@ declare 554 generic { Tcl_DriverThreadActionProc *Tcl_ChannelThreadActionProc(Tcl_ChannelType *chanTypePtr) } +# Slots 555 to 572 are taken already by 8.5 +# TIP #237: Arbitrary-prec Integers (555 ... 559) +# TIP #208: 'chan' Command (560 ... 561) +# TIP #219: Channel Reflection (562 ... 565) +# TIP #237: Add. bignum support (566) +# TIP #181: 'namespace unknown' Cmd (567 ... 568) +# TIP #258: Enhanced Encodings API (569 ... 572) + +# TIP#268: Extended version numbers and requirements. +# The slot is present even if TCL_TIP268 is not activated. + +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 e13d01e..d746ff5 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.75.2.22 2006/08/30 17:24:25 hobbs Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.75.2.23 2006/09/22 01:26:22 andreas_kupries Exp $ */ #include "tclInt.h" @@ -345,6 +345,12 @@ Tcl_CreateInterp() Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS); iPtr->packageUnknown = NULL; +#ifdef TCL_TIP268 + /* TIP #268 */ + iPtr->packagePrefer = (getenv ("TCL_PKG_PREFER_LATEST") == NULL ? + PKG_PREFER_STABLE : + PKG_PREFER_LATEST); +#endif iPtr->cmdCount = 0; iPtr->termOffset = 0; TclInitLiteralTable(&(iPtr->literalTable)); @@ -572,10 +578,17 @@ Tcl_CreateInterp() /* * Register Tcl's version number. + * TIP #268: Full patchlevel instead of just major.minor */ +#ifndef TCL_TIP268 Tcl_PkgProvideEx(interp, "Tcl", TCL_VERSION, (ClientData) &tclStubs); - +#else + Tcl_SetVar2(interp, "tcl_platform", "tip,268", "1", + TCL_GLOBAL_ONLY); + + Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, (ClientData) &tclStubs); +#endif #ifdef Tcl_InitStubs #undef Tcl_InitStubs #endif diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 8ecbe80..be7eec6 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.93.2.6 2005/01/27 22:53:30 andreas_kupries Exp $ + * RCS: @(#) $Id: tclDecls.h,v 1.93.2.7 2006/09/22 01:26:23 andreas_kupries Exp $ */ #ifndef _TCLDECLS @@ -1627,6 +1627,29 @@ EXTERN Tcl_DriverWideSeekProc * Tcl_ChannelWideSeekProc _ANSI_ARGS_(( /* 554 */ EXTERN Tcl_DriverThreadActionProc * Tcl_ChannelThreadActionProc _ANSI_ARGS_(( Tcl_ChannelType * chanTypePtr)); +/* Slot 555 is reserved */ +/* Slot 556 is reserved */ +/* Slot 557 is reserved */ +/* Slot 558 is reserved */ +/* Slot 559 is reserved */ +/* Slot 560 is reserved */ +/* Slot 561 is reserved */ +/* Slot 562 is reserved */ +/* Slot 563 is reserved */ +/* Slot 564 is reserved */ +/* Slot 565 is reserved */ +/* Slot 566 is reserved */ +/* Slot 567 is reserved */ +/* Slot 568 is reserved */ +/* Slot 569 is reserved */ +/* Slot 570 is reserved */ +/* Slot 571 is reserved */ +/* Slot 572 is reserved */ +/* 573 */ +EXTERN int Tcl_PkgRequireProc _ANSI_ARGS_((Tcl_Interp * interp, + CONST char * name, int objc, + Tcl_Obj *CONST objv[], + ClientData * clientDataPtr)); typedef struct TclStubHooks { struct TclPlatStubs *tclPlatStubs; @@ -2241,6 +2264,25 @@ typedef struct TclStubs { void *reserved552; void *reserved553; Tcl_DriverThreadActionProc * (*tcl_ChannelThreadActionProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 554 */ + void *reserved555; + void *reserved556; + void *reserved557; + void *reserved558; + void *reserved559; + void *reserved560; + void *reserved561; + void *reserved562; + void *reserved563; + void *reserved564; + void *reserved565; + void *reserved566; + void *reserved567; + void *reserved568; + void *reserved569; + void *reserved570; + void *reserved571; + void *reserved572; + int (*tcl_PkgRequireProc) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, int objc, Tcl_Obj *CONST objv[], ClientData * clientDataPtr)); /* 573 */ } TclStubs; #ifdef __cplusplus @@ -4321,6 +4363,28 @@ extern TclStubs *tclStubsPtr; #define Tcl_ChannelThreadActionProc \ (tclStubsPtr->tcl_ChannelThreadActionProc) /* 554 */ #endif +/* Slot 555 is reserved */ +/* Slot 556 is reserved */ +/* Slot 557 is reserved */ +/* Slot 558 is reserved */ +/* Slot 559 is reserved */ +/* Slot 560 is reserved */ +/* Slot 561 is reserved */ +/* Slot 562 is reserved */ +/* Slot 563 is reserved */ +/* Slot 564 is reserved */ +/* Slot 565 is reserved */ +/* Slot 566 is reserved */ +/* Slot 567 is reserved */ +/* Slot 568 is reserved */ +/* Slot 569 is reserved */ +/* Slot 570 is reserved */ +/* Slot 571 is reserved */ +/* Slot 572 is reserved */ +#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 0129b5a..4fa0732 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.118.2.22 2006/03/10 14:09:02 vasiljevic Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.118.2.23 2006/09/22 01:26:23 andreas_kupries Exp $ */ #ifndef _TCLINT @@ -1161,6 +1161,17 @@ typedef struct ResolverScheme { /* Pointer to next record in linked list. */ } ResolverScheme; +#ifdef TCL_TIP268 +/* + * TIP #268. + * Values for the selection mode, i.e the package require preferences. + */ + +enum PkgPreferOptions { + PKG_PREFER_LATEST, PKG_PREFER_STABLE +}; +#endif + /* *---------------------------------------------------------------- * This structure defines an interpreter, which is a collection of @@ -1284,6 +1295,15 @@ typedef struct Interp { * require" commands for packages that * aren't described in packageTable. * Malloc'ed, may be NULL. */ +#ifdef TCL_TIP268 + /* + * TIP #268. + * The currently active selection mode, + * i.e the package require preferences. + */ + + int packagePrefer; /* Current package selection mode. */ +#endif /* * Miscellaneous information: diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 4265aa9..de87a0b 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -5,11 +5,16 @@ * the "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.9.2.4 2006/08/30 17:24:07 hobbs Exp $ + * RCS: @(#) $Id: tclPkg.c,v 1.9.2.5 2006/09/22 01:26:23 andreas_kupries Exp $ + * + * TIP #268. + * Heavily rewritten to handle the extend version numbers, and extended + * package requirements. */ #include "tclInt.h" @@ -50,6 +55,7 @@ typedef struct Package { * Prototypes for procedures defined in this file: */ +#ifndef TCL_TIP268 static int CheckVersion _ANSI_ARGS_((Tcl_Interp *interp, CONST char *string)); static int ComparePkgVersions _ANSI_ARGS_((CONST char *v1, @@ -57,6 +63,24 @@ static int ComparePkgVersions _ANSI_ARGS_((CONST char *v1, int *satPtr)); 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 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); +#endif /* *---------------------------------------------------------------------- @@ -83,24 +107,29 @@ static Package * FindPackage _ANSI_ARGS_((Tcl_Interp *interp, int Tcl_PkgProvide(interp, name, version) - Tcl_Interp *interp; /* Interpreter in which package is now + Tcl_Interp *interp; /* Interpreter in which package is now * available. */ - CONST char *name; /* Name of package. */ - CONST char *version; /* Version string for package. */ + CONST char *name; /* Name of package. */ + CONST char *version; /* Version string for package. */ { return Tcl_PkgProvideEx(interp, name, version, (ClientData) NULL); } int Tcl_PkgProvideEx(interp, name, version, clientData) - Tcl_Interp *interp; /* Interpreter in which package is now + Tcl_Interp *interp; /* Interpreter in which package is now * available. */ - CONST char *name; /* Name of package. */ - CONST char *version; /* Version string for package. */ - ClientData clientData; /* clientdata for this package (normally - * used for C callback function table) */ + CONST char *name; /* Name of package. */ + CONST char *version; /* Version string for package. */ + ClientData clientData; /* clientdata for this package (normally + * used for C callback function table) */ { Package *pkgPtr; +#ifdef TCL_TIP268 + char* pvi; + char* vi; + int res; +#endif pkgPtr = FindPackage(interp, name); if (pkgPtr->version == NULL) { @@ -109,21 +138,36 @@ Tcl_PkgProvideEx(interp, name, version, clientData) pkgPtr->clientData = clientData; return TCL_OK; } +#ifndef TCL_TIP268 if (ComparePkgVersions(pkgPtr->version, version, (int *) NULL) == 0) { +#else + 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) { +#endif if (clientData != NULL) { pkgPtr->clientData = clientData; } return TCL_OK; } Tcl_AppendResult(interp, "conflicting versions provided for package \"", - name, "\": ", pkgPtr->version, ", then ", version, (char *) NULL); + name, "\": ", pkgPtr->version, ", then ", version, (char *) NULL); return TCL_ERROR; } /* *---------------------------------------------------------------------- * - * Tcl_PkgRequire / Tcl_PkgRequireEx -- + * Tcl_PkgRequire / Tcl_PkgRequireEx / Tcl_PkgRequireProc -- * * This procedure is called by code that depends on a particular * version of a particular package. If the package is not already @@ -149,42 +193,63 @@ Tcl_PkgProvideEx(interp, name, version, clientData) *---------------------------------------------------------------------- */ +#ifndef TCL_TIP268 +/* + * Empty definition for Stubs when TIP 268 is not activated. + */ +int +Tcl_PkgRequireProc(interp,name,reqc,reqv,clientDataPtr) + 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; +{ + return TCL_ERROR; +} +#endif + CONST char * Tcl_PkgRequire(interp, name, version, exact) - Tcl_Interp *interp; /* Interpreter in which package is now - * available. */ - CONST char *name; /* Name of desired package. */ - CONST char *version; /* Version string for desired version; - * NULL means use the latest version + Tcl_Interp *interp; /* Interpreter in which package is now * available. */ - int exact; /* Non-zero means that only the particular - * version given is acceptable. Zero means - * use the latest compatible version. */ + CONST char *name; /* Name of desired package. */ + CONST char *version; /* Version string for desired version; NULL + * means use the latest version available. */ + int exact; /* Non-zero means that only the particular + * version given is acceptable. Zero means use + * the latest compatible version. */ { return Tcl_PkgRequireEx(interp, name, version, exact, (ClientData *) NULL); } CONST char * Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr) - Tcl_Interp *interp; /* Interpreter in which package is now + Tcl_Interp *interp; /* Interpreter in which package is now * available. */ - CONST char *name; /* Name of desired package. */ - CONST char *version; /* Version string for desired version; + CONST char *name; /* Name of desired package. */ + CONST char *version; /* Version string for desired version; * NULL means use the latest version * available. */ - int exact; /* Non-zero means that only the particular + int exact; /* Non-zero means that only the particular * version given is acceptable. Zero means * use the latest compatible version. */ - ClientData *clientDataPtr; /* Used to return the client data for this + ClientData *clientDataPtr; /* Used to return the client data for this * package. If it is NULL then the client * data is not returned. This is unchanged * if this call fails for any reason. */ { +#ifndef TCL_TIP268 Package *pkgPtr; PkgAvail *availPtr, *bestPtr; char *script; int code, satisfies, result, pass; Tcl_DString command; +#else + Tcl_Obj *ov; + int res; +#endif /* * If an attempt is being made to load this into a standalone executable @@ -257,16 +322,56 @@ Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr) tclEmptyStringRep = &tclEmptyString; Tcl_AppendResult(interp, "Cannot load package \"", name, - "\" in standalone executable: This package is not ", - "compiled with stub support", NULL); + "\" in standalone executable: This package is not ", + "compiled with stub support", NULL); return NULL; } +#ifdef TCL_TIP268 + /* 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; + } + + return Tcl_GetString (Tcl_GetObjResult (interp)); +} + +int +Tcl_PkgRequireProc(interp,name,reqc,reqv,clientDataPtr) + 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; + +#endif /* - * It can take up to three passes to find the package: one pass to - * run the "package unknown" script, one to run the "package ifneeded" - * script for a specific version, and a final pass to lookup the - * package loaded by the "package ifneeded" script. + * It can take up to three passes to find the package: one pass to run the + * "package unknown" script, one to run the "package ifneeded" script for + * a specific version, and a final pass to lookup the package loaded by + * the "package ifneeded" script. */ for (pass = 1; ; pass++) { @@ -282,42 +387,115 @@ Tcl_PkgRequireEx(interp, name, version, exact, 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 } /* - * The package isn't yet present. Search the list of available + * The package isn't yet present. Search the list of available * versions and invoke the script for the best available version. + * + * For TIP 268 we are actually locating the best, and the best stable + * version. One of them is then chosen based on the selection mode. */ - +#ifndef TCL_TIP268 bestPtr = NULL; for (availPtr = pkgPtr->availPtr; availPtr != NULL; availPtr = availPtr->nextPtr) { 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 + * should not happen. This should have been caught by the + * 'package ifneeded' registering the package. + */ +#endif continue; } +#ifndef TCL_TIP268 if (version != NULL) { result = ComparePkgVersions(availPtr->version, version, &satisfies); if ((result != 0) && exact) { +#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); + availVersion = NULL; +#endif continue; } +#ifdef TCL_TIP268 + } + + /* We have found a version which is better than our max. */ + + if (reqc > 0) { + /* Check satisfaction of requirements */ + satisfies = AllRequirementsSatisfied (availVersion, reqc, reqv); +#endif if (!satisfies) { +#ifdef TCL_TIP268 + Tcl_Free (availVersion); + availVersion = NULL; +#endif continue; } } bestPtr = availPtr; +#ifdef TCL_TIP268 + if (bestVersion != NULL) Tcl_Free (bestVersion); + bestVersion = availVersion; + availVersion = NULL; + + /* 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; +#endif } if (bestPtr != NULL) { /* - * We found an ifneeded script for the package. Be careful while - * executing it: this could cause reentrancy, so (a) protect the + * We found an ifneeded script for the package. Be careful while + * executing it: this could cause reentrancy, so (a) protect the * script itself from deletion and (b) don't assume that bestPtr * will still exist when the script completes. */ @@ -331,13 +509,19 @@ Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr) Tcl_Release((ClientData) script); pkgPtr = FindPackage(interp, name); if (code == TCL_OK) { +#ifdef TCL_TIP268 + Tcl_ResetResult(interp); +#endif if (pkgPtr->version == NULL) { +#ifndef TCL_TIP268 Tcl_ResetResult(interp); +#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)) { /* At this point, it is clear that a prior @@ -375,8 +559,84 @@ Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr) versionToProvide, " failed: package ", name, " ", pkgPtr->version, " provided instead", NULL); +#else + } 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 (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. + * + * 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. + * + * 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 + * to a failure to satisfy the requirement. + */ + + if (reqc > 0) { + satisfies = AllRequirementsSatisfied (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); + } + } + /* + * 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); +#endif } +#ifndef TCL_TIP268 /* * Warning generation now disabled if (code == TCL_OK) { @@ -395,13 +655,14 @@ Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr) 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; } @@ -425,15 +686,19 @@ Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr) pkgPtr->version = NULL; } pkgPtr->clientData = NULL; +#ifndef TCL_TIP268 return NULL; +#else + return TCL_ERROR; +#endif } break; } /* - * Package 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). + * 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). */ if (pass > 1) { @@ -444,62 +709,99 @@ Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr) Tcl_DStringInit(&command); Tcl_DStringAppend(&command, script, -1); Tcl_DStringAppendElement(&command, name); +#ifndef TCL_TIP268 Tcl_DStringAppend(&command, " ", 1); Tcl_DStringAppend(&command, (version != NULL) ? version : "{}", -1); if (exact) { Tcl_DStringAppend(&command, " -exact", 7); } +#else + AddRequirementsToDString(&command, reqc, reqv); +#endif code = Tcl_EvalEx(interp, Tcl_DStringValue(&command), - Tcl_DStringLength(&command), TCL_EVAL_GLOBAL); + 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); } } if (pkgPtr->version == NULL) { - Tcl_AppendResult(interp, "can't find package ", name, - (char *) NULL); + Tcl_AppendResult(interp, "can't find package ", name, (char *) NULL); +#ifndef TCL_TIP268 if (version != NULL) { Tcl_AppendResult(interp, " ", version, (char *) NULL); } return NULL; +#else + AddRequirementsToResult(interp, reqc, reqv); + return TCL_ERROR; +#endif } /* - * At this point we know that the package is present. Make sure that the - * provided version meets the current requirement. + * At this point we know that the package is present. Make sure that the + * provided version meets the current requirements. */ +#ifndef TCL_TIP268 if (version == NULL) { if (clientDataPtr) { *clientDataPtr = pkgPtr->clientData; } return pkgPtr->version; +#else + if (reqc == 0) { + satisfies = 1; + } else { + CheckVersionAndConvert (interp, pkgPtr->version, &pkgVersionI, NULL); + satisfies = AllRequirementsSatisfied (pkgVersionI, reqc, reqv); + + Tcl_Free (pkgVersionI); +#endif } +#ifndef TCL_TIP268 result = ComparePkgVersions(pkgPtr->version, version, &satisfies); if ((satisfies && !exact) || (result == 0)) { +#else + if (satisfies) { +#endif 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, ", need ", version, - (char *) NULL); + name, "\": have ", pkgPtr->version, +#ifndef TCL_TIP268 + ", need ", version, (char *) NULL); return NULL; +#else + ", need", (char*) NULL); + AddRequirementsToResult (interp, reqc, reqv); + return TCL_ERROR; +#endif } /* @@ -526,13 +828,13 @@ Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr) CONST char * Tcl_PkgPresent(interp, name, version, exact) - Tcl_Interp *interp; /* Interpreter in which package is now + Tcl_Interp *interp; /* Interpreter in which package is now * available. */ - CONST char *name; /* Name of desired package. */ - CONST char *version; /* Version string for desired version; + CONST char *name; /* Name of desired package. */ + CONST char *version; /* Version string for desired version; * NULL means use the latest version * available. */ - int exact; /* Non-zero means that only the particular + int exact; /* Non-zero means that only the particular * version given is acceptable. Zero means * use the latest compatible version. */ { @@ -541,16 +843,16 @@ Tcl_PkgPresent(interp, name, version, exact) CONST char * Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr) - Tcl_Interp *interp; /* Interpreter in which package is now + Tcl_Interp *interp; /* Interpreter in which package is now * available. */ - CONST char *name; /* Name of desired package. */ - CONST char *version; /* Version string for desired version; + CONST char *name; /* Name of desired package. */ + CONST char *version; /* Version string for desired version; * NULL means use the latest version * available. */ - int exact; /* Non-zero means that only the particular + int exact; /* Non-zero means that only the particular * version given is acceptable. Zero means * use the latest compatible version. */ - ClientData *clientDataPtr; /* Used to return the client data for this + ClientData *clientDataPtr; /* Used to return the client data for this * package. If it is NULL then the client * data is not returned. This is unchanged * if this call fails for any reason. */ @@ -564,6 +866,11 @@ Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr) 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 @@ -577,7 +884,20 @@ Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr) 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; @@ -619,21 +939,28 @@ Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr) *---------------------------------------------------------------------- */ - /* ARGSUSED */ +/* ARGSUSED */ int Tcl_PackageObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { static CONST char *pkgOptions[] = { - "forget", "ifneeded", "names", "present", "provide", "require", - "unknown", "vcompare", "versions", "vsatisfies", (char *) NULL + "forget", "ifneeded", "names", +#ifdef TCL_TIP268 + "prefer", +#endif + "present", "provide", "require", "unknown", "vcompare", + "versions", "vsatisfies", (char *) NULL }; enum pkgOptions { - PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, PKG_PRESENT, - PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE, + PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, +#ifdef TCL_TIP268 + PKG_PREFER, +#endif + PKG_PRESENT, PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE, PKG_VERSIONS, PKG_VSATISFIES }; Interp *iPtr = (Interp *) interp; @@ -645,6 +972,10 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) Tcl_HashTable *tablePtr; CONST char *version; char *argv2, *argv3, *argv4; +#ifdef TCL_TIP268 + char* iva = NULL; + char* ivb = NULL; +#endif if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); @@ -652,10 +983,11 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) } if (Tcl_GetIndexFromObj(interp, objv[1], pkgOptions, "option", 0, - &optionIndex) != TCL_OK) { + &optionIndex) != TCL_OK) { return TCL_ERROR; } switch ((enum pkgOptions) optionIndex) { +#ifndef TCL_TIP268 case PKG_FORGET: { char *keyString; for (i = 2; i < objc; i++) { @@ -679,23 +1011,98 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) ckfree((char *) pkgPtr); } break; +#else + 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; + } + 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 (CheckVersionAndConvert(interp, argv3, &argv3i, NULL) != TCL_OK) { + return TCL_ERROR; +#endif + } +#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; +#endif } +#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; + prevPtr = availPtr, availPtr = availPtr->nextPtr) { + + if (CheckVersionAndConvert (interp, availPtr->version, &avi, NULL) != TCL_OK) { + Tcl_Free (argv3i); +#endif 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); + + if (res == 0){ + if (objc == 4) { + Tcl_Free (argv3i); + Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE); +#endif return TCL_OK; } +#ifndef TCL_TIP268 pkgPtr = (Package *) Tcl_GetHashValue(hPtr); } else { pkgPtr = FindPackage(interp, argv2); @@ -715,7 +1122,12 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) } 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)); @@ -727,40 +1139,169 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) availPtr->nextPtr = prevPtr->nextPtr; prevPtr->nextPtr = availPtr; } +#else + } + Tcl_Free (argv3i); + if (objc == 4) { + return TCL_OK; + } + if (availPtr == NULL) { + availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail)); + availPtr->version = ckalloc((unsigned) (length + 1)); + strcpy(availPtr->version, argv3); + 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); + break; + } + case PKG_NAMES: { + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } + tablePtr = &iPtr->packageTable; + for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; + hPtr = Tcl_NextHashEntry(&search)) { + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) { + Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr)); + } + } + break; + } + case PKG_PRESENT: { + if (objc < 3) { + presentSyntax: + 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 (CheckVersionAndConvert(interp, version, NULL, NULL) != TCL_OK) { +#endif 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; + } + 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) { + return TCL_ERROR; + } + Tcl_SetObjResult( interp, Tcl_NewStringObj( version, -1 ) ); + break; + } + case PKG_PROVIDE: { + if ((objc != 3) && (objc != 4)) { + Tcl_WrongNumArgs(interp, 2, objv, "package ?version?"); + return TCL_ERROR; + } + argv2 = Tcl_GetString(objv[2]); + 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 } +#ifndef TCL_TIP268 case PKG_PRESENT: { if (objc < 3) { presentSyntax: Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?"); return TCL_ERROR; +#else + argv3 = Tcl_GetString(objv[3]); + 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 ?requirement...?"); + return TCL_ERROR; + } + version = NULL; + 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 version = NULL; +#ifndef TCL_TIP268 if (objc == (4 + exact)) { version = Tcl_GetString(objv[3 + exact]); if (CheckVersion(interp, version) != TCL_OK) { @@ -776,16 +1317,74 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) version = Tcl_PkgPresent(interp, argv2, version, exact); } if (version == NULL) { +#else + argv3 = Tcl_GetString(objv[3]); + + Tcl_IncrRefCount (ov); + res = Tcl_PkgRequireProc(interp, argv3, 1, &ov, NULL); + Tcl_DecrRefCount (ov); + 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 + break; + } + 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; + } + 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; + } else if (objc == 3) { + /* Set value. */ + int new; + if (Tcl_GetIndexFromObj(interp, objv[2], pkgPreferOptions, "preference", 0, + &new) != TCL_OK) { +#endif return TCL_ERROR; } +#ifndef TCL_TIP268 argv2 = Tcl_GetString(objv[2]); if (objc == 3) { hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); @@ -796,13 +1395,20 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) } } 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: @@ -835,7 +1441,18 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) } Tcl_SetObjResult( interp, Tcl_NewStringObj( version, -1 ) ); break; +#else + /* 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"); + return TCL_ERROR; +#endif } +#ifndef TCL_TIP268 case PKG_UNKNOWN: { int length; if (objc == 2) { @@ -859,7 +1476,17 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) 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 */ + return TCL_ERROR; +#endif } +#ifndef TCL_TIP268 case PKG_VCOMPARE: { if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "version1 version2"); @@ -874,12 +1501,36 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) Tcl_SetIntObj(Tcl_GetObjResult(interp), ComparePkgVersions(argv2, argv3, (int *) NULL)); break; +#else + + /* 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) { + 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) { + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + 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) { @@ -890,7 +1541,9 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) } } break; +#endif } +#ifndef TCL_TIP268 case PKG_VSATISFIES: { if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "version1 version2"); @@ -905,10 +1558,42 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) ComparePkgVersions(argv2, argv3, &satisfies); Tcl_SetIntObj(Tcl_GetObjResult(interp), satisfies); break; +#else + break; + } + case PKG_VSATISFIES: { + char* argv2i = NULL; + + if (objc < 4) { + 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); + return TCL_ERROR; +#endif } +#ifdef TCL_TIP268 + + satisfies = AllRequirementsSatisfied (argv2i, objc-3, objv+3); + Tcl_Free (argv2i); + + Tcl_SetIntObj(Tcl_GetObjResult(interp), satisfies); + break; + } + default: { + panic("Tcl_PackageObjCmd: bad option index to pkgOptions"); + } +#endif } return TCL_OK; } @@ -934,8 +1619,8 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) static Package * FindPackage(interp, name) - Tcl_Interp *interp; /* Interpreter to use for package lookup. */ - CONST char *name; /* Name of package to fine. */ + Tcl_Interp *interp; /* Interpreter to use for package lookup. */ + CONST char *name; /* Name of package to fine. */ { Interp *iPtr = (Interp *) interp; Tcl_HashEntry *hPtr; @@ -975,7 +1660,7 @@ FindPackage(interp, name) void TclFreePackageInfo(iPtr) - Interp *iPtr; /* Interpereter that is being deleted. */ + Interp *iPtr; /* Interpreter that is being deleted. */ { Package *pkgPtr; Tcl_HashSearch search; @@ -983,7 +1668,7 @@ TclFreePackageInfo(iPtr) PkgAvail *availPtr; for (hPtr = Tcl_FirstHashEntry(&iPtr->packageTable, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { pkgPtr = (Package *) Tcl_GetHashValue(hPtr); if (pkgPtr->version != NULL) { ckfree(pkgPtr->version); @@ -1006,7 +1691,7 @@ TclFreePackageInfo(iPtr) /* *---------------------------------------------------------------------- * - * CheckVersion -- + * CheckVersion / CheckVersionAndConvert -- * * This procedure checks to see whether a version number has * valid syntax. @@ -1023,30 +1708,103 @@ TclFreePackageInfo(iPtr) */ static int +#ifndef TCL_TIP268 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. */ +#else +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 { 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+ 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 '.' + */ + +#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 == '.')))) + ) { + /* INTL: digit */ +#endif goto error; } +#ifdef TCL_TIP268 + 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; } +#endif 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); + } + if (stable != NULL) { + *stable = !hasunstable; + } +#endif return TCL_OK; } - error: + error: +#ifdef TCL_TIP268 + Tcl_Free (ibuf); +#endif Tcl_AppendResult(interp, "expected version number but got \"", string, "\"", (char *) NULL); return TCL_ERROR; @@ -1055,9 +1813,9 @@ CheckVersion(interp, string) /* *---------------------------------------------------------------------- * - * ComparePkgVersions -- + * ComparePkgVersions / CompareVersions -- * - * This procedure compares two version numbers. + * This procedure compares two version numbers. (268: in internal rep). * * Results: * The return value is -1 if v1 is less than v2, 0 if the two @@ -1073,6 +1831,7 @@ CheckVersion(interp, string) */ static int +#ifndef TCL_TIP268 ComparePkgVersions(v1, v2, satPtr) CONST char *v1; CONST char *v2; /* Versions strings, of form 2.1.3 (any @@ -1082,14 +1841,34 @@ ComparePkgVersions(v1, v2, satPtr) * v1 "satisfies" v2: v1 is greater than * or equal to v2 and both version numbers * have the same major number. */ +#else +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 ".". If those numbers don't match - * then the comparison is over; otherwise, we loop back for the - * next number. + * 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. + * + * 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; @@ -1099,18 +1878,34 @@ ComparePkgVersions(v1, v2, satPtr) */ 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 match. + * Compare and go on to the next version number if the current numbers + * match. */ if (n1 != n2) { @@ -1126,14 +1921,421 @@ ComparePkgVersions(v1, v2, satPtr) } 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; } + + 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(interp, reqc, reqv) + Tcl_Interp* interp; + int reqc; /* Requirements to check. */ + Tcl_Obj *CONST reqv[]; +{ + int i; + for (i = 0; i < reqc; i++) { + if ((CheckRequirement(interp, Tcl_GetString(reqv[i])) != TCL_OK)) { + 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(interp, string) + 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; +#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); + *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; +#endif +} +#ifdef TCL_TIP268 + +/* + *---------------------------------------------------------------------- + * + * AddRequirementsToResult -- + * + * This function accumulates requirements in the interpreter result. + * + * Results: + * None. + * + * Side effects: + * The interpreter result is extended. + * + *---------------------------------------------------------------------- + */ + +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. */ +{ + 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(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. */ +{ + 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(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. */ +{ + 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(havei, req) + 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 { + 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; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ +#endif diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index b61bf2c..87ce53f 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.79.2.9 2005/01/27 22:53:34 andreas_kupries Exp $ + * RCS: @(#) $Id: tclStubInit.c,v 1.79.2.10 2006/09/22 01:26:23 andreas_kupries Exp $ */ #include "tclInt.h" @@ -1014,6 +1014,25 @@ TclStubs tclStubs = { NULL, /* 552 */ NULL, /* 553 */ Tcl_ChannelThreadActionProc, /* 554 */ + NULL, /* 555 */ + NULL, /* 556 */ + NULL, /* 557 */ + NULL, /* 558 */ + NULL, /* 559 */ + NULL, /* 560 */ + NULL, /* 561 */ + NULL, /* 562 */ + NULL, /* 563 */ + NULL, /* 564 */ + NULL, /* 565 */ + NULL, /* 566 */ + NULL, /* 567 */ + NULL, /* 568 */ + NULL, /* 569 */ + NULL, /* 570 */ + NULL, /* 571 */ + NULL, /* 572 */ + Tcl_PkgRequireProc, /* 573 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclTest.c b/generic/tclTest.c index 52ab14e..73ef0ab 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.62.2.12 2006/03/19 22:47:29 vincentdarley Exp $ + * RCS: @(#) $Id: tclTest.c,v 1.62.2.13 2006/09/22 01:26:23 andreas_kupries Exp $ */ #define TCL_TEST @@ -548,7 +548,12 @@ Tcltest_Init(interp) "-appinitprocclosestderr", "-appinitprocsetrcfile", (char *) NULL }; +#ifndef TCL_TIP268 if (Tcl_PkgProvide(interp, "Tcltest", TCL_VERSION) == TCL_ERROR) { +#else + /* TIP #268: Full patchlevel instead of just major.minor */ + if (Tcl_PkgProvide(interp, "Tcltest", TCL_PATCH_LEVEL) == TCL_ERROR) { +#endif return TCL_ERROR; } diff --git a/library/package.tcl b/library/package.tcl index fa6b01c..04145dd 100644 --- a/library/package.tcl +++ b/library/package.tcl @@ -3,7 +3,7 @@ # utility procs formerly in init.tcl which can be loaded on demand # for package management. # -# RCS: @(#) $Id: package.tcl,v 1.23.2.3 2005/07/22 21:59:41 dgp Exp $ +# RCS: @(#) $Id: package.tcl,v 1.23.2.4 2006/09/22 01:26:24 andreas_kupries Exp $ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1998 Sun Microsystems, Inc. @@ -471,7 +471,12 @@ proc tclPkgSetup {dir pkg version files} { # version - Version of desired package. Not used. # exact - Either "-exact" or omitted. Not used. -proc tclPkgUnknown {name version {exact {}}} { + +proc tclPkgUnknown [expr { + [info exists tcl_platform(tip,268)] + ? "name args" + : "name version {exact {}}" + }] { global auto_path env if {![info exists auto_path]} { @@ -564,43 +569,86 @@ proc tclPkgUnknown {name version {exact {}}} { # Arguments: # original - original [package unknown] procedure # name - Name of desired package. Not used. +#ifndef TCL_TIP268 # version - Version of desired package. Not used. # exact - Either "-exact" or omitted. Not used. +#else +# args - List of requirements. Not used. +#endif -proc tcl::MacOSXPkgUnknown {original name version {exact {}}} { - - # First do the cross-platform default search - uplevel 1 $original [list $name $version $exact] +if {[info exists tcl_platform(tip,268)]} { + proc tcl::MacOSXPkgUnknown {original name args} { + # First do the cross-platform default search + uplevel 1 $original [linsert $args 0 $name] - # Now do MacOSX specific searching - global auto_path + # Now do MacOSX specific searching + global auto_path - if {![info exists auto_path]} { - return - } - # Cache the auto_path, because it may change while we run through - # the first set of pkgIndex.tcl files - set old_path [set use_path $auto_path] - while {[llength $use_path]} { - set dir [lindex $use_path end] - # get the pkgIndex files out of the subdirectories - foreach file [glob -directory $dir -join -nocomplain \ - * Resources Scripts pkgIndex.tcl] { - set dir [file dirname $file] - if {[file readable $file] && ![info exists procdDirs($dir)]} { - if {[catch {source $file} msg]} { - tclLog "error reading package index file $file: $msg" - } else { - set procdDirs($dir) 1 + if {![info exists auto_path]} { + return + } + # Cache the auto_path, because it may change while we run through + # the first set of pkgIndex.tcl files + set old_path [set use_path $auto_path] + while {[llength $use_path]} { + set dir [lindex $use_path end] + # get the pkgIndex files out of the subdirectories + foreach file [glob -directory $dir -join -nocomplain \ + * Resources Scripts pkgIndex.tcl] { + set dir [file dirname $file] + if {[file readable $file] && ![info exists procdDirs($dir)]} { + if {[catch {source $file} msg]} { + tclLog "error reading package index file $file: $msg" + } else { + set procdDirs($dir) 1 + } } } + set use_path [lrange $use_path 0 end-1] + if {$old_path ne $auto_path} { + foreach dir $auto_path { + lappend use_path $dir + } + set old_path $auto_path + } } - set use_path [lrange $use_path 0 end-1] - if {$old_path ne $auto_path} { - foreach dir $auto_path { - lappend use_path $dir + } +} else { + proc tcl::MacOSXPkgUnknown {original name version {exact {}}} { + + # First do the cross-platform default search + uplevel 1 $original [list $name $version $exact] + + # Now do MacOSX specific searching + global auto_path + + if {![info exists auto_path]} { + return + } + # Cache the auto_path, because it may change while we run through + # the first set of pkgIndex.tcl files + set old_path [set use_path $auto_path] + while {[llength $use_path]} { + set dir [lindex $use_path end] + # get the pkgIndex files out of the subdirectories + foreach file [glob -directory $dir -join -nocomplain \ + * Resources Scripts pkgIndex.tcl] { + set dir [file dirname $file] + if {[file readable $file] && ![info exists procdDirs($dir)]} { + if {[catch {source $file} msg]} { + tclLog "error reading package index file $file: $msg" + } else { + set procdDirs($dir) 1 + } + } + } + set use_path [lrange $use_path 0 end-1] + if {$old_path ne $auto_path} { + foreach dir $auto_path { + lappend use_path $dir + } + set old_path $auto_path } - set old_path $auto_path } } } diff --git a/tests/pkg.test b/tests/pkg.test index 83488a1..baea4d5 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.4 2006/04/05 01:42:16 dgp Exp $ +# RCS: @(#) $Id: pkg.test,v 1.9.12.5 2006/09/22 01:26:24 andreas_kupries Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -31,6 +31,9 @@ package unknown {} set oldPath $auto_path set auto_path "" +testConstraint tip268 [info exists tcl_platform(tip,268)] +testConstraint !tip268 [expr {![info exists tcl_platform(tip,268)]}] + test pkg-1.1 {Tcl_PkgProvide procedure} { package forget t package provide t 2.3 @@ -56,6 +59,23 @@ test pkg-1.5 {Tcl_PkgProvide procedure} { package provide t 2.3 } {} +test pkg-1.6 {Tcl_PkgProvide procedure} tip268 { + package forget t + package provide t 2.3a1 +} {} + +set n 0 +foreach v { + 2.3k1 2a3a2 2ab3 2.a4 2.b4 2b.4 2a.4 2ba4 2a4b1 + 2b4a1 2b3b2 +} { + test pkg-1.7.$n {Tcl_PkgProvide procedure} tip268 { + package forget t + list [catch {package provide t $v} msg] $msg + } [list 1 "expected version number but got \"$v\""] + incr n +} + test pkg-2.1 {Tcl_PkgRequire procedure, picking best version} { package forget t foreach i {1.4 3.4 2.3 2.4 2.2} { @@ -117,14 +137,24 @@ test pkg-2.7 {Tcl_PkgRequire procedure, can't find suitable version} { } list [catch {package require t 4.1} msg] $msg } {1 {can't find package t 4.1}} -test pkg-2.8 {Tcl_PkgRequire procedure, can't find suitable version} { +test pkg-2.8 {Tcl_PkgRequire procedure, can't find suitable version} !tip268 { package forget t package unknown {} foreach i {1.4 3.4 2.3 2.4 2.2} { package ifneeded t $i "set x $i" } list [catch {package require -exact t 1.3} msg] $msg + } {1 {can't find package t 1.3}} +test pkg-2.8-268 {Tcl_PkgRequire procedure, can't find suitable version} tip268 { + package forget t + package unknown {} + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i" + } + list [catch {package require -exact t 1.3} msg] $msg + +} {1 {can't find package t 1.3-1.4}} test pkg-2.9 {Tcl_PkgRequire procedure, can't find suitable version} { package forget t package unknown {} @@ -153,7 +183,7 @@ test pkg-2.12 {Tcl_PkgRequire procedure, self-deleting script} { package require t 1.2 set x } {1.2} -test pkg-2.13 {Tcl_PkgRequire procedure, "package unknown" support} { +test pkg-2.13-!268 {Tcl_PkgRequire procedure, "package unknown" support} !tip268 { proc pkgUnknown args { global x set x $args @@ -169,6 +199,26 @@ test pkg-2.13 {Tcl_PkgRequire procedure, "package unknown" support} { package unknown {} set x } {t 1.5 -exact} + +test pkg-2.13-268 {Tcl_PkgRequire procedure, "package unknown" support} tip268 { + proc pkgUnknown args { + # args = name requirement + # requirement = v-v (for exact version) + global x + set x $args + package provide [lindex $args 0] [lindex [split [lindex $args 1] -] 0] + } + package forget t + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i" + } + package unknown pkgUnknown + set x xxx + package require -exact t 1.5 + package unknown {} + set x +} {t 1.5-1.6} + test pkg-2.14 {Tcl_PkgRequire procedure, "package unknown" support} { proc pkgUnknown args { package ifneeded t 1.2 "set x loaded; package provide t 1.2" @@ -180,7 +230,7 @@ test pkg-2.14 {Tcl_PkgRequire procedure, "package unknown" support} { package unknown {} set result } {1.2 loaded} -test pkg-2.15 {Tcl_PkgRequire procedure, "package unknown" support} { +test pkg-2.15 {Tcl_PkgRequire procedure, "package unknown" support} !tip268 { proc pkgUnknown args { global x set x $args @@ -193,7 +243,20 @@ test pkg-2.15 {Tcl_PkgRequire procedure, "package unknown" support} { package unknown {} set x } {{a b} {}} -test pkg-2.16 {Tcl_PkgRequire procedure, "package unknown" error} { +test pkg-2.15-268 {Tcl_PkgRequire procedure, "package unknown" support} tip268 { + proc pkgUnknown args { + global x + set x $args + package provide [lindex $args 0] 2.0 + } + package forget {a b} + package unknown pkgUnknown + set x xxx + package require {a b} + package unknown {} + set x +} {{a b}} +test pkg-2.16 {Tcl_PkgRequire procedure, "package unknown" error} !tip268 { proc pkgUnknown args { error "testing package unknown" } @@ -211,7 +274,25 @@ test pkg-2.16 {Tcl_PkgRequire procedure, "package unknown" error} { ("package unknown" script) invoked from within "package require t"}} -test pkg-2.17 {Tcl_PkgRequire procedure, "package unknown" doesn't load package} { +test pkg-2.16-268 {Tcl_PkgRequire procedure, "package unknown" error} tip268 { + proc pkgUnknown args { + error "testing package unknown" + } + package forget t + package unknown pkgUnknown + set result [list [catch {package require t} msg] $msg $errorInfo] + package unknown {} + set result +} {1 {testing package unknown} {testing package unknown + while executing +"error "testing package unknown"" + (procedure "pkgUnknown" line 2) + invoked from within +"pkgUnknown t" + ("package unknown" script) + invoked from within +"package require t"}} +test pkg-2.17 {Tcl_PkgRequire procedure, "package unknown" doesn't load package} !tip268 { proc pkgUnknown args { global x set x $args @@ -226,6 +307,21 @@ test pkg-2.17 {Tcl_PkgRequire procedure, "package unknown" doesn't load package} package unknown {} set result } {1 {can't find package t 1.5} {t 1.5 -exact}} +test pkg-2.17-268 {Tcl_PkgRequire procedure, "package unknown" doesn't load package} tip268 { + proc pkgUnknown args { + global x + set x $args + } + package forget t + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i" + } + package unknown pkgUnknown + set x xxx + 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}} test pkg-2.18 {Tcl_PkgRequire procedure, version checks} { package forget t package provide t 2.3 @@ -256,11 +352,16 @@ test pkg-2.23 {Tcl_PkgRequire procedure, version checks} { package provide t 2.3 package require -exact t 2.3 } {2.3} -test pkg-2.24 {Tcl_PkgRequire procedure, version checks} { +test pkg-2.24 {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}} +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}} 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} @@ -466,6 +567,40 @@ test pkg-2.43 {Tcl_PkgRequire: consistent return values (1162286)} -setup { package unknown $saveUnknown } -returnCodes error -match glob -result {bad return code:*} + + +test pkg-2.50 {Tcl_PkgRequire procedure, picking best stable version} tip268 { + package forget t + foreach i {1.4 3.4 4.0a1 2.3 2.4 2.2} { + package ifneeded t $i "set x $i; package provide t $i" + } + set x xxx + package require t + set x +} {3.4} + +test pkg-2.51 {Tcl_PkgRequire procedure, picking best stable version} tip268 { + package forget t + foreach i {1.2b1 1.2 1.3a2 1.3} { + package ifneeded t $i "set x $i; package provide t $i" + } + set x xxx + package require t + set x +} {1.3} + +test pkg-2.52 {Tcl_PkgRequire procedure, picking best stable version} tip268 { + package forget t + foreach i {1.2b1 1.2 1.3 1.3a2} { + package ifneeded t $i "set x $i; package provide t $i" + } + set x xxx + package require t + set x +} {1.3} + + + test pkg-3.1 {Tcl_PackageCmd procedure} { list [catch {package} msg] $msg } {1 {wrong # args: should be "package option ?arg arg ...?"}} @@ -589,16 +724,24 @@ test pkg-3.21 {Tcl_PackageCmd procedure, "provide" option} { package forget t list [catch {package provide t a.b} msg] $msg } {1 {expected version number but got "a.b"}} -test pkg-3.22 {Tcl_PackageCmd procedure, "require" option} { +test pkg-3.22 {Tcl_PackageCmd procedure, "require" option} !tip268 { list [catch {package require} msg] $msg } {1 {wrong # args: should be "package require ?-exact? package ?version?"}} -test pkg-3.23 {Tcl_PackageCmd procedure, "require" option} { +test pkg-3.22-268 {Tcl_PackageCmd procedure, "require" option} tip268 { + list [catch {package require} msg] $msg +} {1 {wrong # args: should be "package require ?-exact? package ?requirement...?"}} +test pkg-3.23 {Tcl_PackageCmd procedure, "require" option} !tip268 { list [catch {package require a b c} msg] $msg } {1 {wrong # args: should be "package require ?-exact? package ?version?"}} -test pkg-3.24 {Tcl_PackageCmd procedure, "require" option} { +test pkg-3.24 {Tcl_PackageCmd procedure, "require" option} !tip268 { list [catch {package require -exact a b c} msg] $msg } {1 {wrong # args: should be "package require ?-exact? package ?version?"}} -test pkg-3.25 {Tcl_PackageCmd procedure, "require" option} { +test pkg-3.24-268 {Tcl_PackageCmd procedure, "require" option} tip268 { + list [catch {package require -exact a b c} msg] $msg + # Exact syntax: -exact name version + # name ?requirement...? +} {1 {wrong # args: should be "package require ?-exact? package ?requirement...?"}} +test pkg-3.25 {Tcl_PackageCmd procedure, "require" option} !tip268 { list [catch {package require -bs a b} msg] $msg } {1 {wrong # args: should be "package require ?-exact? package ?version?"}} test pkg-3.26 {Tcl_PackageCmd procedure, "require" option} { @@ -607,12 +750,18 @@ test pkg-3.26 {Tcl_PackageCmd procedure, "require" option} { test pkg-3.27 {Tcl_PackageCmd procedure, "require" option} { list [catch {package require -exact x a.b} msg] $msg } {1 {expected version number but got "a.b"}} -test pkg-3.28 {Tcl_PackageCmd procedure, "require" option} { +test pkg-3.28 {Tcl_PackageCmd procedure, "require" option} !tip268 { list [catch {package require -exact x} msg] $msg } {1 {wrong # args: should be "package require ?-exact? package ?version?"}} -test pkg-3.29 {Tcl_PackageCmd procedure, "require" option} { +test pkg-3.28-268 {Tcl_PackageCmd procedure, "require" option} tip268 { + list [catch {package require -exact x} msg] $msg +} {1 {wrong # args: should be "package require ?-exact? package ?requirement...?"}} +test pkg-3.29 {Tcl_PackageCmd procedure, "require" option} !tip268 { list [catch {package require -exact} msg] $msg } {1 {wrong # args: should be "package require ?-exact? package ?version?"}} +test pkg-3.29-268 {Tcl_PackageCmd procedure, "require" option} tip268 { + list [catch {package require -exact} msg] $msg +} {1 {wrong # args: should be "package require ?-exact? package ?requirement...?"}} test pkg-3.30 {Tcl_PackageCmd procedure, "require" option} { package forget t package provide t 2.3 @@ -678,10 +827,13 @@ test pkg-3.46 {Tcl_PackageCmd procedure, "versions" option} { package ifneeded t 2.4 y package versions t } {2.3 2.4} -test pkg-3.47 {Tcl_PackageCmd procedure, "vsatisfies" option} { +test pkg-3.47 {Tcl_PackageCmd procedure, "vsatisfies" option} !tip268 { list [catch {package vsatisfies a} msg] $msg } {1 {wrong # args: should be "package vsatisfies version1 version2"}} -test pkg-3.48 {Tcl_PackageCmd procedure, "vsatisfies" option} { +test pkg-3.47-268 {Tcl_PackageCmd procedure, "vsatisfies" option} tip268 { + list [catch {package vsatisfies a} msg] $msg +} {1 {wrong # args: should be "package vsatisfies version requirement requirement..."}} +test pkg-3.48 {Tcl_PackageCmd procedure, "vsatisfies" option} !tip268 { list [catch {package vsatisfies a b c} msg] $msg } {1 {wrong # args: should be "package vsatisfies version1 version2"}} test pkg-3.49 {Tcl_PackageCmd procedure, "vsatisfies" option} { @@ -696,9 +848,24 @@ test pkg-3.51 {Tcl_PackageCmd procedure, "vsatisfies" option} { test pkg-3.52 {Tcl_PackageCmd procedure, "vsatisfies" option} { package vs 2.3 1.2 } {0} -test pkg-3.53 {Tcl_PackageCmd procedure, "versions" option} { +test pkg-3.53 {Tcl_PackageCmd procedure, "versions" option} !tip268 { list [catch {package foo} msg] $msg } {1 {bad option "foo": must be forget, ifneeded, names, present, provide, require, unknown, vcompare, versions, or vsatisfies}} +test pkg-3.53-268 {Tcl_PackageCmd procedure, "versions" option} tip268 { + list [catch {package foo} msg] $msg +} {1 {bad option "foo": must be forget, ifneeded, names, prefer, present, provide, require, unknown, vcompare, versions, or vsatisfies}} + +test pkg-3.54 {Tcl_PackageCmd procedure, "vsatisfies" option} tip268 { + list [catch {package vsatisfies 2.1 2.1-3.2-4.5} msg] $msg +} {1 {expected versionMin-versionMax but got "2.1-3.2-4.5"}} + +test pkg-3.55 {Tcl_PackageCmd procedure, "vsatisfies" option} tip268 { + list [catch {package vsatisfies 2.1 3.2-x.y} msg] $msg +} {1 {expected version number but got "x.y"}} + +test pkg-3.56 {Tcl_PackageCmd procedure, "vsatisfies" option} tip268 { + list [catch {package vsatisfies 2.1 x.y-3.2} msg] $msg +} {1 {expected version number but got "x.y"}} # No tests for FindPackage; can't think up anything detectable # errors. @@ -845,6 +1012,279 @@ test pkg-7.18 {Tcl_PackageCmd procedure, "present" option} { list [catch {package present -exact} msg] $msg } {1 {wrong # args: should be "package present ?-exact? package ?version?"}} + +set n 0 +foreach {r p vs vc} { + 8.5a0 8.5a5 1 -1 + 8.5a0 8.5b1 1 -1 + 8.5a0 8.5.1 1 -1 + 8.5a0 8.6a0 1 -1 + 8.5a0 8.6b0 1 -1 + 8.5a0 8.6.0 1 -1 + 8.5a6 8.5a5 0 1 + 8.5a6 8.5b1 1 -1 + 8.5a6 8.5.1 1 -1 + 8.5a6 8.6a0 1 -1 + 8.5a6 8.6b0 1 -1 + 8.5a6 8.6.0 1 -1 + 8.5b0 8.5a5 0 1 + 8.5b0 8.5b1 1 -1 + 8.5b0 8.5.1 1 -1 + 8.5b0 8.6a0 1 -1 + 8.5b0 8.6b0 1 -1 + 8.5b0 8.6.0 1 -1 + 8.5b2 8.5a5 0 1 + 8.5b2 8.5b1 0 1 + 8.5b2 8.5.1 1 -1 + 8.5b2 8.6a0 1 -1 + 8.5b2 8.6b0 1 -1 + 8.5b2 8.6.0 1 -1 + 8.5 8.5a5 1 1 + 8.5 8.5b1 1 1 + 8.5 8.5.1 1 -1 + 8.5 8.6a0 1 -1 + 8.5 8.6b0 1 -1 + 8.5 8.6.0 1 -1 + 8.5.0 8.5a5 0 1 + 8.5.0 8.5b1 0 1 + 8.5.0 8.5.1 1 -1 + 8.5.0 8.6a0 1 -1 + 8.5.0 8.6b0 1 -1 + 8.5.0 8.6.0 1 -1 +} { + test package-vsatisfies-1.$n {package vsatisfies} tip268 { + package vsatisfies $p $r + } $vs + + test package-vcompare-1.$n {package vcompare} tip268 { + package vcompare $r $p + } $vc + + incr n +} + +set n 0 +foreach {required provided satisfied} { + 8.5a0- 8.5a5 1 + 8.5a0- 8.5b1 1 + 8.5a0- 8.5.1 1 + 8.5a0- 8.6a0 1 + 8.5a0- 8.6b0 1 + 8.5a0- 8.6.0 1 + 8.5a6- 8.5a5 0 + 8.5a6- 8.5b1 1 + 8.5a6- 8.5.1 1 + 8.5a6- 8.6a0 1 + 8.5a6- 8.6b0 1 + 8.5a6- 8.6.0 1 + 8.5b0- 8.5a5 0 + 8.5b0- 8.5b1 1 + 8.5b0- 8.5.1 1 + 8.5b0- 8.6a0 1 + 8.5b0- 8.6b0 1 + 8.5b0- 8.6.0 1 + 8.5b2- 8.5a5 0 + 8.5b2- 8.5b1 0 + 8.5b2- 8.5.1 1 + 8.5b2- 8.6a0 1 + 8.5b2- 8.6b0 1 + 8.5b2- 8.6.0 1 + 8.5- 8.5a5 1 + 8.5- 8.5b1 1 + 8.5- 8.5.1 1 + 8.5- 8.6a0 1 + 8.5- 8.6b0 1 + 8.5- 8.6.0 1 + 8.5.0- 8.5a5 0 + 8.5.0- 8.5b1 0 + 8.5.0- 8.5.1 1 + 8.5.0- 8.6a0 1 + 8.5.0- 8.6b0 1 + 8.5.0- 8.6.0 1 + 8.5a0-7 8.5a5 0 + 8.5a0-7 8.5b1 0 + 8.5a0-7 8.5.1 0 + 8.5a0-7 8.6a0 0 + 8.5a0-7 8.6b0 0 + 8.5a0-7 8.6.0 0 + 8.5a6-7 8.5a5 0 + 8.5a6-7 8.5b1 0 + 8.5a6-7 8.5.1 0 + 8.5a6-7 8.6a0 0 + 8.5a6-7 8.6b0 0 + 8.5a6-7 8.6.0 0 + 8.5b0-7 8.5a5 0 + 8.5b0-7 8.5b1 0 + 8.5b0-7 8.5.1 0 + 8.5b0-7 8.6a0 0 + 8.5b0-7 8.6b0 0 + 8.5b0-7 8.6.0 0 + 8.5b2-7 8.5a5 0 + 8.5b2-7 8.5b1 0 + 8.5b2-7 8.5.1 0 + 8.5b2-7 8.6a0 0 + 8.5b2-7 8.6b0 0 + 8.5b2-7 8.6.0 0 + 8.5-7 8.5a5 0 + 8.5-7 8.5b1 0 + 8.5-7 8.5.1 0 + 8.5-7 8.6a0 0 + 8.5-7 8.6b0 0 + 8.5-7 8.6.0 0 + 8.5.0-7 8.5a5 0 + 8.5.0-7 8.5b1 0 + 8.5.0-7 8.5.1 0 + 8.5.0-7 8.6a0 0 + 8.5.0-7 8.6b0 0 + 8.5.0-7 8.6.0 0 + 8.5a0-8.6.1 8.5a5 1 + 8.5a0-8.6.1 8.5b1 1 + 8.5a0-8.6.1 8.5.1 1 + 8.5a0-8.6.1 8.6a0 1 + 8.5a0-8.6.1 8.6b0 1 + 8.5a0-8.6.1 8.6.0 1 + 8.5a6-8.6.1 8.5a5 0 + 8.5a6-8.6.1 8.5b1 1 + 8.5a6-8.6.1 8.5.1 1 + 8.5a6-8.6.1 8.6a0 1 + 8.5a6-8.6.1 8.6b0 1 + 8.5a6-8.6.1 8.6.0 1 + 8.5b0-8.6.1 8.5a5 0 + 8.5b0-8.6.1 8.5b1 1 + 8.5b0-8.6.1 8.5.1 1 + 8.5b0-8.6.1 8.6a0 1 + 8.5b0-8.6.1 8.6b0 1 + 8.5b0-8.6.1 8.6.0 1 + 8.5b2-8.6.1 8.5a5 0 + 8.5b2-8.6.1 8.5b1 0 + 8.5b2-8.6.1 8.5.1 1 + 8.5b2-8.6.1 8.6a0 1 + 8.5b2-8.6.1 8.6b0 1 + 8.5b2-8.6.1 8.6.0 1 + 8.5-8.6.1 8.5a5 1 + 8.5-8.6.1 8.5b1 1 + 8.5-8.6.1 8.5.1 1 + 8.5-8.6.1 8.6a0 1 + 8.5-8.6.1 8.6b0 1 + 8.5-8.6.1 8.6.0 1 + 8.5.0-8.6.1 8.5a5 0 + 8.5.0-8.6.1 8.5b1 0 + 8.5.0-8.6.1 8.5.1 1 + 8.5.0-8.6.1 8.6a0 1 + 8.5.0-8.6.1 8.6b0 1 + 8.5.0-8.6.1 8.6.0 1 + 8.5a0-8.5a0 8.5a0 1 + 8.5a0-8.5a0 8.5b1 0 + 8.5a0-8.5a0 8.4 0 + 8.5b0-8.5b0 8.5a5 0 + 8.5b0-8.5b0 8.5b0 1 + 8.5b0-8.5b0 8.5.1 0 + 8.5-8.5 8.5a5 0 + 8.5-8.5 8.5b1 0 + 8.5-8.5 8.5 1 + 8.5-8.5 8.5.1 0 + 8.5.0-8.5.0 8.5a5 0 + 8.5.0-8.5.0 8.5b1 0 + 8.5.0-8.5.0 8.5.0 1 + 8.5.0-8.5.0 8.5.1 0 + 8.5.0-8.5.0 8.6a0 0 + 8.5.0-8.5.0 8.6b0 0 + 8.5.0-8.5.0 8.6.0 0 + 8.2 9 0 + 8.2- 9 1 + 8.2-8.5 9 0 + 8.2-9.1 9 1 + + 8.5-8.5 8.5b1 0 + 8.5a0-8.5 8.5b1 0 + 8.5a0-8.5.1 8.5b1 1 + + 8.5-8.5 8.5 1 + 8.5.0-8.5.0 8.5 1 + 8.5a0-8.5.0 8.5 0 + +} { + test package-vsatisfies-2.$n "package vsatisfies $provided $required" tip268 { + package vsatisfies $provided $required + } $satisfied + incr n +} + +test package-vsatisfies-3.0 "package vsatisfies multiple" tip268 { + # yes no + package vsatisfies 8.4 8.4 7.3 +} 1 + +test package-vsatisfies-3.1 "package vsatisfies multiple" tip268 { + # no yes + package vsatisfies 8.4 7.3 8.4 +} 1 + +test package-vsatisfies-3.2 "package vsatisfies multiple" tip268 { + # yes yes + package vsatisfies 8.4.2 8.4 8.4.1 +} 1 + +test package-vsatisfies-3.3 "package vsatisfies multiple" tip268 { + # no no + package vsatisfies 8.4 7.3 6.1 +} 0 + + +proc prefer {args} { + set ip [interp create] + lappend res [$ip eval {package prefer}] + foreach mode $args { + lappend res [$ip eval [list package prefer $mode]] + } + interp delete $ip + return $res +} + +test package-prefer-1.0 {default} tip268 { + prefer +} stable + +test package-prefer-1.1 {default} tip268 { + set ::env(TCL_PKG_PREFER_LATEST) stable ; # value not relevant! + set res [prefer] + unset ::env(TCL_PKG_PREFER_LATEST) + set res +} latest + +test package-prefer-2.0 {wrong\#args} tip268 { + catch {package prefer foo bar} msg + set msg +} {wrong # args: should be "package prefer ?latest|stable?"} + +test package-prefer-2.1 {bogus argument} tip268 { + catch {package prefer foo} msg + set msg +} {bad preference "foo": must be latest or stable} + +test package-prefer-3.0 {set, keep} tip268 { + package prefer stable +} stable + +test package-prefer-3.1 {set stable, keep} tip268 { + prefer stable +} {stable stable} + +test package-prefer-3.2 {set latest, change} tip268 { + prefer latest +} {stable latest} + +test package-prefer-3.3 {set latest, keep} tip268 { + prefer latest latest +} {stable latest latest} + +test package-prefer-3.3 {set stable, rejected} tip268 { + prefer latest stable +} {stable latest latest} + +rename prefer {} + + set auto_path $oldPath package unknown $oldPkgUnknown concat diff --git a/tests/platform.test b/tests/platform.test index f9d7aca..01bf787 100644 --- a/tests/platform.test +++ b/tests/platform.test @@ -22,6 +22,7 @@ test platform-1.1 {TclpSetVariables: tcl_platform} { interp create i i eval {catch {unset tcl_platform(debug)}} i eval {catch {unset tcl_platform(threaded)}} + i eval {catch {unset tcl_platform(tip,268)}} set result [i eval {lsort [array names tcl_platform]}] interp delete i set result diff --git a/tests/safe.test b/tests/safe.test index a26cb92..15dfa85 100644 --- a/tests/safe.test +++ b/tests/safe.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: safe.test,v 1.13.2.1 2005/06/22 16:02:42 dgp Exp $ +# RCS: @(#) $Id: safe.test,v 1.13.2.2 2006/09/22 01:26:24 andreas_kupries Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -187,6 +187,10 @@ test safe-6.3 {test safe interpreters knowledge of the world} { if {$threaded != -1} { set r [lreplace $r $threaded $threaded] } + set tip [lsearch $r "tip,268"] + if {$tip != -1} { + set r [lreplace $r $tip $tip] + } set r } {byteOrder platform wordSize} |