summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorandreas_kupries <akupries@shaw.ca>2006-09-22 01:26:21 (GMT)
committerandreas_kupries <akupries@shaw.ca>2006-09-22 01:26:21 (GMT)
commite071f14d95c6a3e37911f58a3ca71da73b6a72d2 (patch)
tree32acbff94cb87475dcf718f476fd8fb8e668cff2
parente54225009c1133029084660b54b930783c1fbb94 (diff)
downloadtcl-e071f14d95c6a3e37911f58a3ca71da73b6a72d2.zip
tcl-e071f14d95c6a3e37911f58a3ca71da73b6a72d2.tar.gz
tcl-e071f14d95c6a3e37911f58a3ca71da73b6a72d2.tar.bz2
* 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:
-rw-r--r--ChangeLog16
-rw-r--r--doc/PkgRequire.34
-rw-r--r--generic/tcl.decls22
-rw-r--r--generic/tclBasic.c17
-rw-r--r--generic/tclDecls.h66
-rw-r--r--generic/tclInt.h22
-rw-r--r--generic/tclPkg.c1374
-rw-r--r--generic/tclStubInit.c21
-rw-r--r--generic/tclTest.c7
-rw-r--r--library/package.tcl108
-rw-r--r--tests/pkg.test472
-rw-r--r--tests/platform.test1
-rw-r--r--tests/safe.test6
13 files changed, 1993 insertions, 143 deletions
diff --git a/ChangeLog b/ChangeLog
index 2b7dd43..147636d 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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}