summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorandreas_kupries <andreas_kupries@noemail.net>2006-09-22 18:13:25 (GMT)
committerandreas_kupries <andreas_kupries@noemail.net>2006-09-22 18:13:25 (GMT)
commitb582a8fdc7e8829a1dfd36550181d3492cf8b381 (patch)
treef67d58798c4d5ba6ee60a07d1f99fe77001dee13
parentc90f137bf46a53f55c597d3e79ab2a491424a90c (diff)
downloadtcl-b582a8fdc7e8829a1dfd36550181d3492cf8b381.zip
tcl-b582a8fdc7e8829a1dfd36550181d3492cf8b381.tar.gz
tcl-b582a8fdc7e8829a1dfd36550181d3492cf8b381.tar.bz2
TIP#268 IMPLEMENTATION
* generic/tclDecls.h: Regenerated from tcl.decls. * generic/tclStubInit.c: * doc/PkgRequire.3: Documentation of extended API, * doc/package.n: extended testsuite. * tests/pkg.test: * generic/tcl.decls: Implementation. * generic/tclBasic.c: * generic/tclConfig.c: * generic/tclInt.h: * generic/tclPkg.c: * generic/tclTest.c: * generic/tclTomMathInterface.c: * library/init.tcl: * library/package.tcl: * library/tm.tcl: FossilOrigin-Name: 055195c6bce7cf3bc2a1dc2c88b333d9e9b4485c
Diffstat
-rw-r--r--ChangeLog22
-rw-r--r--doc/PkgRequire.313
-rw-r--r--doc/package.n144
-rw-r--r--generic/tcl.decls19
-rw-r--r--generic/tclBasic.c11
-rw-r--r--generic/tclConfig.c12
-rw-r--r--generic/tclDecls.h15
-rw-r--r--generic/tclInt.h20
-rw-r--r--generic/tclPkg.c987
-rw-r--r--generic/tclStubInit.c3
-rw-r--r--generic/tclTest.c6
-rw-r--r--generic/tclTomMathInterface.c6
-rw-r--r--library/init.tcl4
-rw-r--r--library/package.tcl8
-rw-r--r--library/tm.tcl10
-rw-r--r--tests/pkg.test383
16 files changed, 1455 insertions, 208 deletions
diff --git a/ChangeLog b/ChangeLog
index 73d45da..aedcec2 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,25 @@
+2006-09-22 Andreas Kupries <andreask@activestate.com>
+
+ TIP#268 IMPLEMENTATION
+
+ * generic/tclDecls.h: Regenerated from tcl.decls.
+ * generic/tclStubInit.c:
+
+ * doc/PkgRequire.3: Documentation of extended API,
+ * doc/package.n: extended testsuite.
+ * tests/pkg.test:
+
+ * generic/tcl.decls: Implementation.
+ * generic/tclBasic.c:
+ * generic/tclConfig.c:
+ * generic/tclInt.h:
+ * generic/tclPkg.c:
+ * generic/tclTest.c:
+ * generic/tclTomMathInterface.c:
+ * library/init.tcl:
+ * library/package.tcl:
+ * library/tm.tcl:
+
2006-09-22 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* generic/tclThreadTest.c (TclCreateThread): Use NULL instead of 0 as
diff --git a/doc/PkgRequire.3 b/doc/PkgRequire.3
index 4cb939a..5256176 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.9 2004/10/07 15:15:47 dkf Exp $
+'\" RCS: @(#) $Id: PkgRequire.3,v 1.10 2006/09/22 18:13:26 andreas_kupries Exp $
'\"
.so man.macros
.TH Tcl_PkgRequire 3 7.5 Tcl "Tcl Library Procedures"
@@ -21,6 +21,9 @@ const char *
const char *
\fBTcl_PkgRequireEx\fR(\fIinterp, name, version, exact, clientDataPtr\fR)
.sp
+int
+\fBTcl_PkgRequireProc\fR(\fIinterp, name, objc, objv, clientDataPtr\fR)
+.sp
const char *
\fBTcl_PkgPresent\fR(\fIinterp, name, version, exact\fR)
.sp
@@ -53,6 +56,10 @@ Arbitrary value to be associated with the package.
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.
+.AP int objc in
+Number of requirements.
+.AP Tcl_Obj* objv[] in
+Array of requirements.
.BE
.SH DESCRIPTION
@@ -82,6 +89,10 @@ 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.
+.PP
+\fBTcl_PkgRequireProc\fR is the form of \fBpackage require\fR handling
+multiple requirements. The other forms are present for backward
+compatibility and translate their invokations to this form.
.SH KEYWORDS
package, present, provide, require, version
diff --git a/doc/package.n b/doc/package.n
index 4700e7c..fa943c2 100644
--- a/doc/package.n
+++ b/doc/package.n
@@ -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: package.n,v 1.11 2006/09/04 19:36:02 hobbs Exp $
+'\" RCS: @(#) $Id: package.n,v 1.12 2006/09/22 18:13:26 andreas_kupries Exp $
'\"
.so man.macros
.TH package n 7.5 Tcl "Tcl Built-In Commands"
@@ -19,11 +19,12 @@ package \- Facilities for package loading and version control
\fBpackage names\fR
\fBpackage present \fR?\fB\-exact\fR? \fIpackage \fR?\fIversion\fR?
\fBpackage provide \fIpackage \fR?\fIversion\fR?
-\fBpackage require \fR?\fB\-exact\fR? \fIpackage \fR?\fIversion\fR?
+\fBpackage require \fR?\fB\-exact\fR? \fIpackage \fR?\fIrequirement...\fR?
\fBpackage unknown \fR?\fIcommand\fR?
\fBpackage vcompare \fIversion1 version2\fR
\fBpackage versions \fIpackage\fR
-\fBpackage vsatisfies \fIversion1 version2\fR
+\fBpackage vsatisfies \fIversion requirement...\fR
+\fBpackage prefer \fR?\fBlatest\fR|\fBstable\fR?
.fi
.BE
@@ -92,25 +93,45 @@ returns the version number that is currently provided, or an
empty string if no \fBpackage provide\fR command has been
invoked for \fIpackage\fR in this interpreter.
.TP
-\fBpackage require \fR?\fB\-exact\fR? \fIpackage \fR?\fIversion\fR?
+\fBpackage require \fR\fB\-exact\fR \fIpackage \fR\fIversion\fR
+This form of the command is translated to the form below using the
+bounded requirement "version-(version+1)", making only the given
+\fIversion\fR acceptable, within the specified level of detail. Deeper
+levels are allowed to vary. Examples:
+.CS
+ -exact 8 => 8-9
+ -exact 8.4 => 8.4-8.5
+ -exact 8.4.14 => 8.4.14-8.4.15
+.CE
+.RS
+For more explanations see below.
+.RE
+.TP
+\fBpackage require \fR\fIpackage \fR?\frequirement...\fR?
This command is typically invoked by Tcl code that wishes to use
a particular version of a particular package. The arguments
indicate which package is wanted, and the command ensures that
a suitable version of the package is loaded into the interpreter.
If the command succeeds, it returns the version number that is
loaded; otherwise it generates an error.
-If both the \fB\-exact\fR
-switch and the \fIversion\fR argument are specified then only the
-given version is acceptable. If \fB\-exact\fR is omitted but
-\fIversion\fR is specified, then versions later than \fIversion\fR
-are also acceptable as long as they have the same major version
-number as \fIversion\fR.
-If both \fB\-exact\fR and \fIversion\fR are omitted then any
-version whatsoever is acceptable.
+.RS
+.PP
+A suitable version of the package is any version which satisfies at
+least one of the requirements, per the rules of \fBpackage
+vsatisfies\fR. If multiple versions are suitable the implementation
+with the highest version is chosen. This last part is additionally
+influenced by the selection mode set with \fBpackage prefer\fR.
+.PP
+In the "stable" selection mode the command will select the highest
+stable version satisfying the requirements, if any. If no stable
+version satisfies the requirements, the highest unstable version
+satisfying the requirements will be selected. In the "latest"
+selection mode the command will accept the highest version satisfying
+all the requirements, regardless of its stableness.
+.PP
If a version of \fIpackage\fR has already been provided (by invoking
the \fBpackage provide\fR command), then its version number must
-satisfy the criteria given by \fB\-exact\fR and \fIversion\fR and
-the command returns immediately.
+satisfy the \fIrequirement\fRs and the command returns immediately.
Otherwise, the command searches the database of information provided by
previous \fBpackage ifneeded\fR commands to see if an acceptable
version of the package is available.
@@ -126,6 +147,7 @@ it completes, Tcl checks again to see if the package is now provided
or if there is a \fBpackage ifneeded\fR script for it.
If all of these steps fail to provide an acceptable version of the
package, then the command returns an error.
+.RE
.TP
\fBpackage unknown \fR?\fIcommand\fR?
This command supplies a ``last resort'' command to invoke during
@@ -133,13 +155,13 @@ This command supplies a ``last resort'' command to invoke during
in the \fBpackage ifneeded\fR database.
If the \fIcommand\fR argument is supplied, it contains the first part
of a command; when the command is invoked during a \fBpackage require\fR
-command, Tcl appends two additional arguments giving the desired package
-name and version.
+command, Tcl appends one or more additional arguments giving the desired
+package name and requirements.
For example, if \fIcommand\fR is \fBfoo bar\fR and later the command
\fBpackage require test 2.4\fR is invoked, then Tcl will execute
the command \fBfoo bar test 2.4\fR to load the package.
-If no version number is supplied to the \fBpackage require\fR command,
-then the version argument for the invoked command will be an empty string.
+If no requirements are supplied to the \fBpackage require\fR command,
+then only the name will be added to invoked command.
If the \fBpackage unknown\fR command is invoked without a \fIcommand\fR
argument, then the current \fBpackage unknown\fR script is returned,
or an empty string if there is none.
@@ -156,11 +178,77 @@ Returns a list of all the version numbers of \fIpackage\fR
for which information has been provided by \fBpackage ifneeded\fR
commands.
.TP
-\fBpackage vsatisfies \fIversion1 version2\fR
-Returns 1 if scripts written for \fIversion2\fR will work unchanged
-with \fIversion1\fR (i.e. \fIversion1\fR is equal to or greater
-than \fIversion2\fR and they both have the same major version
-number), 0 otherwise.
+\fBpackage vsatisfies \fIversion requirement...\fR
+Returns 1 if the \fIversion\fR satisfies at least one of the given
+requirements, and 0 otherwise. Each \fIrequirement\fR is allowed to
+have any of the forms:
+.RS
+.TP
+min
+This form is called "min-bounded".
+.TP
+min-
+This form is called "min-unbound".
+.TP
+min-max
+This form is called "bounded".
+.RE
+.RS
+.PP
+where "min" and "max" are valid version numbers. The current syntax is
+a special case of the extended syntax, keeping backward
+compatibility. Regarding satisfaction the rules are:
+.RE
+.RS
+.IP [1]
+The \fIversion\fR has to pass at least one of the listed
+\fIrequirement\fRs to be satisfactory.
+.IP [2]
+A version satisfies a "bounded" requirement when
+.RS
+.IP [a]
+For \fImin\fR equal to the \fImax\fR if, and only if the \fIversion\fR
+is equal to the \fImin\fR.
+.IP [b]
+Otherwise if, and only if the \fIversion\fR is greater than or equal
+to the \fImin\fR, and less than the \fImax\fR, where both \fImin\fR
+and \fImax\fR have been padded internally with 'a0'. Note that while
+the comparison to \fImin\fR is inclusive, the comparison to
+\fImax\fR is exclusive.
+.RE
+.IP [3]
+A "min-bounded" requirement is a "bounded" requirement in disguise,
+with the \fImax\fR part implicitly specified as the next higher major
+version number of the \fImin\fR part. A version satisfies it per the
+rules above.
+.IP [4]
+A \fIversion\fR satisfies a "min-unbound" requirement if, and only if
+it is greater than or equal to the \fImin\fR, where the \fImin\fR has
+been padded internally with 'a0'. There is no constraint to a maximum.
+.RE
+.TP
+\fBpackage prefer \fR?\fBlatest\fR|\fBstable\fR?
+With no arguments, the commands returns either "latest" or "stable",
+whichever describes the current mode of selection logic used by
+\fBpackage require\fR.
+.RS
+.PP
+When passed the argument "latest", it sets the selection logic mode to
+"latest".
+.PP
+When passed the argument "stable", if the mode is already "stable",
+that value is kept. If the mode is already "latest", then the attempt
+to set it back to "stable" is ineffective and the mode value remains
+"latest".
+.PP
+When passed any other value as an argument, raise an invalid argument
+error.
+.PP
+When an interpreter, its initial selection mode value is set to
+"stable" unless the environment variable \fBTCL_PKG_PREFER_LATEST\fR
+is set. If that environment variable is defined (with any value) then
+the initial (and permanent) selection mode value is set to "latest".
+.RE
.SH "VERSION NUMBERS"
.PP
Version numbers consist of one or more decimal numbers separated
@@ -172,6 +260,16 @@ For example, version 2.1 is later than 1.3 and version
3.4.6 is later than 3.3.5.
Missing fields are equivalent to zeroes: version 1.3 is the
same as version 1.3.0 and 1.3.0.0, so it is earlier than 1.3.1 or 1.3.0.2.
+In addition, the letters 'a' (alpha) and/or 'b' (beta) may appear
+exactly once to replace a dot for separation. These letters
+semantically add a negative specifier into the version, where 'a' is
+-2, and 'b' is -1. Each may be specified only once, and 'a' or 'b' are
+mutually exclusive in a specifier. Thus 1.3a1 becomes (semantically)
+1.3.-3.1, 1.3b1 is 1.3.-2.1. Negative numbers are not directly allowed
+in version specifiers.
+A version number not containing the letters 'a' or 'b' as specified
+above is called a \fBstable\fR version, whereas presence of the letters
+causes the version to be called is \fBunstable\fR.
A later version number is assumed to be upwards compatible with
an earlier version number as long as both versions have the same
major version number.
diff --git a/generic/tcl.decls b/generic/tcl.decls
index e19db3f..189bcaf 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -11,7 +11,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: tcl.decls,v 1.120 2006/02/08 21:41:27 dgp Exp $
+# RCS: @(#) $Id: tcl.decls,v 1.121 2006/09/22 18:13:27 andreas_kupries Exp $
library tcl
@@ -971,6 +971,7 @@ declare 273 generic {
int Tcl_PkgProvide(Tcl_Interp *interp, CONST char *name,
CONST char *version)
}
+# TIP #268: The internally used new Require function is in slot 573.
declare 274 generic {
CONST84_RETURN char * Tcl_PkgRequire(Tcl_Interp *interp, CONST char *name,
CONST char *version, int exact)
@@ -1989,7 +1990,7 @@ declare 554 generic {
Tcl_DriverThreadActionProc *Tcl_ChannelThreadActionProc(Tcl_ChannelType *chanTypePtr)
}
-# TIP #237:
+# TIP#237 (Arbitrary-precision Integers) kevin kenny
declare 555 generic {
Tcl_Obj* Tcl_NewBignumObj( mp_int* value )
@@ -2007,7 +2008,7 @@ declare 559 generic {
int Tcl_GetBignumAndClearObj( Tcl_Interp* interp, Tcl_Obj* obj, mp_int* value )
}
-# TIP #208:
+# TIP #208 ('chan' Command) jeffh
declare 560 generic {
int Tcl_TruncateChannel(Tcl_Channel chan, Tcl_WideInt length)
}
@@ -2031,14 +2032,14 @@ declare 565 generic {
void Tcl_GetChannelError (Tcl_Channel chan, Tcl_Obj** msg)
}
-# Additional conversion functions for bignum support
+# TIP #237 (Additional conversion functions for bignum support)
declare 566 generic {
int Tcl_InitBignumFromDouble(Tcl_Interp* interp, double initval,
mp_int *toInit)
}
-# TIP 181
+# TIP#181 (namespace unknown Command)
declare 567 generic {
Tcl_Obj *Tcl_GetNamespaceUnknownHandler(Tcl_Interp *interp,
Tcl_Namespace *nsPtr)
@@ -2049,7 +2050,7 @@ declare 568 generic {
Tcl_Obj *handlerPtr)
}
-# TIP#258 Enhanced Interface for Encodings
+# TIP#258 (Enhanced Interface for Encodings)
declare 569 generic {
int Tcl_GetEncodingFromObj(Tcl_Interp* interp, Tcl_Obj* objPtr,
@@ -2065,6 +2066,12 @@ declare 572 generic {
CONST char *Tcl_GetEncodingNameFromEnvironment(Tcl_DString* bufPtr)
}
+# TIP#268: Extended version numbers and requirements
+declare 573 generic {
+ int Tcl_PkgRequireProc(Tcl_Interp *interp, CONST char *name,
+ int objc, Tcl_Obj *CONST objv[], ClientData *clientDataPtr)
+}
+
##############################################################################
# Define the platform specific public Tcl interface. These functions are
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 1c3eb2c..c931281 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclBasic.c,v 1.196 2006/08/30 19:33:11 hobbs Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.197 2006/09/22 18:13:27 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -326,6 +326,12 @@ Tcl_CreateInterp(void)
Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS);
iPtr->packageUnknown = NULL;
+
+ /* TIP #268 */
+ iPtr->packagePrefer = (getenv ("TCL_PKG_PREFER_LATEST") == NULL ?
+ PKG_PREFER_STABLE :
+ PKG_PREFER_LATEST);
+
iPtr->cmdCount = 0;
TclInitLiteralTable(&(iPtr->literalTable));
iPtr->compileEpoch = 0;
@@ -562,9 +568,10 @@ Tcl_CreateInterp(void)
/*
* Register Tcl's version number.
+ * TIP #268: Full patchlevel instead of just major.minor
*/
- Tcl_PkgProvideEx(interp, "Tcl", TCL_VERSION, (ClientData) &tclStubs);
+ Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, (ClientData) &tclStubs);
#ifdef Tcl_InitStubs
#undef Tcl_InitStubs
diff --git a/generic/tclConfig.c b/generic/tclConfig.c
index 756b396..c65c501 100644
--- a/generic/tclConfig.c
+++ b/generic/tclConfig.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclConfig.c,v 1.10 2005/11/01 15:30:52 dkf Exp $
+ * RCS: @(#) $Id: tclConfig.c,v 1.11 2006/09/22 18:13:28 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -68,14 +68,18 @@ Tcl_RegisterConfig(
CONST char *valEncoding) /* Name of the encoding used to store the
* configuration values, ASCII, thus UTF-8. */
{
- Tcl_Encoding venc = Tcl_GetEncoding(NULL, valEncoding);
- Tcl_Obj *pDB = GetConfigDict(interp);
- Tcl_Obj *pkg = Tcl_NewStringObj(pkgName, -1);
+ Tcl_Encoding venc;
+ Tcl_Obj *pDB;
+ Tcl_Obj *pkg;
Tcl_Obj *pkgDict;
Tcl_DString cmdName;
Tcl_Config *cfg;
int res;
+ venc = Tcl_GetEncoding(NULL, valEncoding);
+ pDB = GetConfigDict(interp);
+ pkg = Tcl_NewStringObj(pkgName, -1);
+
/*
* Phase I: Adding the provided information to the internal database of
* package meta data.
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index 00f009f..35776db 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclDecls.h,v 1.122 2006/02/08 21:41:27 dgp Exp $
+ * RCS: @(#) $Id: tclDecls.h,v 1.123 2006/09/22 18:13:28 andreas_kupries Exp $
*/
#ifndef _TCLDECLS
@@ -3571,6 +3571,14 @@ EXTERN int Tcl_SetEncodingSearchPath _ANSI_ARGS_((
EXTERN CONST char * Tcl_GetEncodingNameFromEnvironment _ANSI_ARGS_((
Tcl_DString* bufPtr));
#endif
+#ifndef Tcl_PkgRequireProc_TCL_DECLARED
+#define Tcl_PkgRequireProc_TCL_DECLARED
+/* 573 */
+EXTERN int Tcl_PkgRequireProc _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * name, int objc,
+ Tcl_Obj *CONST objv[],
+ ClientData * clientDataPtr));
+#endif
typedef struct TclStubHooks {
struct TclPlatStubs *tclPlatStubs;
@@ -4185,6 +4193,7 @@ typedef struct TclStubs {
Tcl_Obj* (*tcl_GetEncodingSearchPath) _ANSI_ARGS_((void)); /* 570 */
int (*tcl_SetEncodingSearchPath) _ANSI_ARGS_((Tcl_Obj* searchPath)); /* 571 */
CONST char * (*tcl_GetEncodingNameFromEnvironment) _ANSI_ARGS_((Tcl_DString* bufPtr)); /* 572 */
+ int (*tcl_PkgRequireProc) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, int objc, Tcl_Obj *CONST objv[], ClientData * clientDataPtr)); /* 573 */
} TclStubs;
#ifdef __cplusplus
@@ -6517,6 +6526,10 @@ extern TclStubs *tclStubsPtr;
#define Tcl_GetEncodingNameFromEnvironment \
(tclStubsPtr->tcl_GetEncodingNameFromEnvironment) /* 572 */
#endif
+#ifndef Tcl_PkgRequireProc
+#define Tcl_PkgRequireProc \
+ (tclStubsPtr->tcl_PkgRequireProc) /* 573 */
+#endif
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 0f34ea5..7b230dc 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInt.h,v 1.275 2006/08/21 01:08:41 das Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.276 2006/09/22 18:13:28 andreas_kupries Exp $
*/
#ifndef _TCLINT
@@ -1260,6 +1260,15 @@ typedef struct ResolverScheme {
typedef struct LimitHandler LimitHandler;
/*
+ * TIP #268.
+ * Values for the selection mode, i.e the package require preferences.
+ */
+
+enum PkgPreferOptions {
+ PKG_PREFER_LATEST, PKG_PREFER_STABLE
+};
+
+/*
*----------------------------------------------------------------
* This structure defines an interpreter, which is a collection of commands
* plus other state information related to interpreting commands, such as
@@ -1376,6 +1385,15 @@ typedef struct Interp {
* NULL. */
/*
+ * TIP #268.
+ * The currently active selection mode,
+ * i.e the package require preferences.
+ */
+
+ int packagePrefer; /* Current package selection mode.
+ */
+
+ /*
* Miscellaneous information:
*/
diff --git a/generic/tclPkg.c b/generic/tclPkg.c
index 9a990a2..0ff2b7c 100644
--- a/generic/tclPkg.c
+++ b/generic/tclPkg.c
@@ -5,11 +5,16 @@
* "package" command and a few C APIs.
*
* Copyright (c) 1996 Sun Microsystems, Inc.
+ * Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net>
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclPkg.c,v 1.15 2006/08/30 17:59:03 hobbs Exp $
+ * RCS: @(#) $Id: tclPkg.c,v 1.16 2006/09/22 18:13:28 andreas_kupries Exp $
+ *
+ * TIP #268.
+ * Heavily rewritten to handle the extend version numbers, and extended
+ * package requirements.
*/
#include "tclInt.h"
@@ -50,10 +55,25 @@ typedef struct Package {
* Prototypes for functions defined in this file:
*/
-static int CheckVersion(Tcl_Interp *interp, CONST char *string);
-static int ComparePkgVersions(CONST char *v1, CONST char *v2,
- int *satPtr);
+static int CheckVersionAndConvert(Tcl_Interp *interp, CONST char *string,
+ char** internal, int* stable);
+
+static int CompareVersions(CONST char *v1i, CONST char *v2i,
+ int *isMajorPtr);
+static int CheckRequirement(Tcl_Interp *interp, CONST char *string);
+static int CheckAllRequirements(Tcl_Interp* interp,
+ int reqc, Tcl_Obj *CONST reqv[]);
+static int RequirementSatisfied(CONST char *havei, CONST char *req);
+static int AllRequirementsSatisfied(CONST char *havei,
+ int reqc, Tcl_Obj *CONST reqv[]);
+static void AddRequirementsToResult(Tcl_Interp* interp,
+ int reqc, Tcl_Obj *CONST reqv[]);
+static void AddRequirementsToDString(Tcl_DString* dstring,
+ int reqc, Tcl_Obj *CONST reqv[]);
static Package * FindPackage(Tcl_Interp *interp, CONST char *name);
+static Tcl_Obj* ExactRequirement(CONST char* version);
+static void VersionCleanupProc(ClientData clientData,
+ Tcl_Interp *interp);
/*
*----------------------------------------------------------------------
@@ -96,6 +116,9 @@ Tcl_PkgProvideEx(
* for C callback function table) */
{
Package *pkgPtr;
+ char* pvi;
+ char* vi;
+ int res;
pkgPtr = FindPackage(interp, name);
if (pkgPtr->version == NULL) {
@@ -104,7 +127,19 @@ Tcl_PkgProvideEx(
pkgPtr->clientData = clientData;
return TCL_OK;
}
- if (ComparePkgVersions(pkgPtr->version, version, NULL) == 0) {
+
+ if (CheckVersionAndConvert (interp, pkgPtr->version, &pvi, NULL) != TCL_OK) {
+ return TCL_ERROR;
+ } else if (CheckVersionAndConvert (interp, version, &vi, NULL) != TCL_OK) {
+ Tcl_Free (pvi);
+ return TCL_ERROR;
+ }
+
+ res = CompareVersions(pvi, vi, NULL);
+ Tcl_Free (pvi);
+ Tcl_Free (vi);
+
+ if (res == 0) {
if (clientData != NULL) {
pkgPtr->clientData = clientData;
}
@@ -118,7 +153,7 @@ Tcl_PkgProvideEx(
/*
*----------------------------------------------------------------------
*
- * Tcl_PkgRequire / Tcl_PkgRequireEx --
+ * Tcl_PkgRequire / Tcl_PkgRequireEx / Tcl_PkgRequireProc --
*
* This function is called by code that depends on a particular version
* of a particular package. If the package is not already provided in the
@@ -171,11 +206,8 @@ Tcl_PkgRequireEx(
* is not returned. This is unchanged if this
* call fails for any reason. */
{
- Package *pkgPtr;
- PkgAvail *availPtr, *bestPtr;
- char *script;
- int code, satisfies, result, pass;
- Tcl_DString command;
+ Tcl_Obj *ov;
+ int res;
/*
* If an attempt is being made to load this into a standalone executable
@@ -248,6 +280,69 @@ Tcl_PkgRequireEx(
return NULL;
}
+ /* Translate between old and new API, and defer to the new function. */
+
+ if (exact) {
+ ov = ExactRequirement (version);
+ } else {
+ ov = Tcl_NewStringObj (version,-1);
+ }
+
+ Tcl_IncrRefCount (ov);
+ res = Tcl_PkgRequireProc(interp, name, 1, &ov, clientDataPtr);
+ Tcl_DecrRefCount (ov);
+
+ if (res != TCL_OK) {
+ return NULL;
+ }
+
+ /* This function returns the version string explictly, and leaves the
+ * interpreter result empty. However "Tcl_PkgRequireProc" above returned
+ * the version through the interpreter result. Simply resetting the result
+ * now potentially deletes the string (obj), and the pointer to its string
+ * rep we have, as our result, may be dangling due to this. Our solution
+ * is to remember the object in interp associated data, with a proper
+ * reference count, and then reset the result. Now pointers will not
+ * dangle. It will be a leak however if nothing is done. So the next time
+ * we come through here we delete the object remembered by this call, as
+ * we can then be sure that there is no pointer to its string around
+ * anymore. Beyond that we have a deletion function which cleans up the last
+ * remembered object which was not cleaned up directly, here.
+ */
+
+ ov = (Tcl_Obj*) Tcl_GetAssocData (interp, "tcl/Tcl_PkgRequireEx", NULL);
+ if (ov != NULL) {
+ Tcl_DecrRefCount (ov);
+ }
+
+ ov = Tcl_GetObjResult (interp);
+ Tcl_IncrRefCount (ov);
+ Tcl_SetAssocData(interp, "tcl/Tcl_PkgRequireEx", VersionCleanupProc,
+ (ClientData) ov);
+ Tcl_ResetResult (interp);
+
+ return Tcl_GetString (ov);
+}
+
+int
+Tcl_PkgRequireProc(
+ Tcl_Interp *interp, /* Interpreter in which package is now
+ * available. */
+ CONST char *name, /* Name of desired package. */
+ int reqc, /* Requirements constraining the desired version. */
+ Tcl_Obj *CONST reqv[], /* 0 means to use the latest version available. */
+ ClientData *clientDataPtr)
+{
+ Interp *iPtr = (Interp *) interp;
+ Package *pkgPtr;
+ PkgAvail *availPtr, *bestPtr, *bestStablePtr;
+ char *availVersion, *bestVersion; /* Internal rep. of versions */
+ int availStable;
+ char *script;
+ int code, satisfies, pass;
+ Tcl_DString command;
+ char* pkgVersionI;
+
/*
* It can take up to three passes to find the package: one pass to run the
* "package unknown" script, one to run the "package ifneeded" script for
@@ -270,36 +365,85 @@ Tcl_PkgRequireEx(
Tcl_AppendResult(interp, "circular package dependency: ",
"attempt to provide ", name, " ",
(char *)(pkgPtr->clientData), " requires ", name, NULL);
- if (version != NULL) {
- Tcl_AppendResult(interp, " ", version, NULL);
- }
- return NULL;
+ AddRequirementsToResult (interp, reqc, reqv);
+ return TCL_ERROR;
}
/*
* The package isn't yet present. Search the list of available
* versions and invoke the script for the best available version.
+ * We are actually locating the best, and the best stable version.
+ * One of them is then chosen based on the selection mode.
*/
- bestPtr = NULL;
- for (availPtr = pkgPtr->availPtr; availPtr != NULL;
- availPtr = availPtr->nextPtr) {
- if ((bestPtr != NULL) && (ComparePkgVersions(availPtr->version,
- bestPtr->version, NULL) <= 0)) {
+ bestPtr = NULL;
+ bestStablePtr = NULL;
+ bestVersion = NULL;
+
+ for (availPtr = pkgPtr->availPtr;
+ availPtr != NULL;
+ availPtr = availPtr->nextPtr) {
+ if (CheckVersionAndConvert (interp, availPtr->version,
+ &availVersion, &availStable) != TCL_OK) {
+ /* The provided version number is has invalid syntax. This
+ * should not happen. This should have been caught by the
+ * 'package ifneeded' registering the package.
+ */
+
continue;
}
- if (version != NULL) {
- result = ComparePkgVersions(availPtr->version, version,
- &satisfies);
- if ((result != 0) && exact) {
+
+ if (bestPtr != NULL) {
+ int res = CompareVersions (availVersion, bestVersion, NULL);
+ /* Note: Use internal reps! */
+ if (res <= 0) {
+ /* The version of the package sought is not as good as the
+ * currently selected version. Ignore it. */
+ Tcl_Free (availVersion);
+ availVersion = NULL;
continue;
}
+ }
+
+ /* We have found a version which is better than our max. */
+
+ if (reqc > 0) {
+ /* Check satisfaction of requirements */
+ satisfies = AllRequirementsSatisfied (availVersion, reqc, reqv);
if (!satisfies) {
+ Tcl_Free (availVersion);
+ availVersion = NULL;
continue;
}
}
+
bestPtr = availPtr;
+
+ if (bestVersion != NULL) Tcl_Free (bestVersion);
+ bestVersion = availVersion;
+
+ /* If this new best version is stable then it also has to be
+ * better than the max stable version found so far.
+ */
+
+ if (availStable) {
+ bestStablePtr = availPtr;
+ }
+ }
+
+ if (bestVersion != NULL) {
+ Tcl_Free (bestVersion);
+ }
+
+ /* Now choose a version among the two best. For 'latest' we simply
+ * take (actually keep) the best. For 'stable' we take the best
+ * stable, if there is any, or the best if there is nothing stable.
+ */
+
+ if ((iPtr->packagePrefer == PKG_PREFER_STABLE) && (bestStablePtr != NULL)) {
+ bestPtr = bestStablePtr;
}
+
if (bestPtr != NULL) {
/*
* We found an ifneeded script for the package. Be careful while
@@ -309,7 +453,7 @@ Tcl_PkgRequireEx(
*/
CONST char *versionToProvide = bestPtr->version;
script = bestPtr->script;
-
+
pkgPtr->clientData = (ClientData) versionToProvide;
Tcl_Preserve((ClientData) script);
Tcl_Preserve((ClientData) versionToProvide);
@@ -325,13 +469,29 @@ Tcl_PkgRequireEx(
name, " ", versionToProvide,
" failed: no version of package ", name,
" provided", NULL);
- } else if (0 != ComparePkgVersions(
- pkgPtr->version, versionToProvide, NULL)) {
- code = TCL_ERROR;
- Tcl_AppendResult(interp, "attempt to provide package ",
- name, " ", versionToProvide, " failed: package ",
- name, " ", pkgPtr->version, " provided instead",
- NULL);
+ } else {
+ char* pvi;
+ char* vi;
+ int res;
+
+ if (CheckVersionAndConvert (interp, pkgPtr->version, &pvi, NULL) != TCL_OK) {
+ code = TCL_ERROR;
+ } else if (CheckVersionAndConvert (interp, versionToProvide, &vi, NULL) != TCL_OK) {
+ Tcl_Free (pvi);
+ code = TCL_ERROR;
+ } else {
+ res = CompareVersions(pvi, vi, NULL);
+ Tcl_Free (pvi);
+ Tcl_Free (vi);
+
+ if (res != 0) {
+ code = TCL_ERROR;
+ Tcl_AppendResult(interp, "attempt to provide package ",
+ name, " ", versionToProvide, " failed: package ",
+ name, " ", pkgPtr->version, " provided instead",
+ NULL);
+ }
+ }
}
} else if (code != TCL_ERROR) {
Tcl_Obj *codePtr = Tcl_NewIntObj(code);
@@ -367,13 +527,14 @@ Tcl_PkgRequireEx(
pkgPtr->version = NULL;
}
pkgPtr->clientData = NULL;
- return NULL;
+ return TCL_ERROR;
}
+
break;
}
/*
- * Package not in the database. If there is a "package unknown"
+ * The package is not in the database. If there is a "package unknown"
* command, invoke it (but only on the first pass; after that, we
* should not get here in the first place).
*/
@@ -381,17 +542,14 @@ Tcl_PkgRequireEx(
if (pass > 1) {
break;
}
+
script = ((Interp *) interp)->packageUnknown;
if (script != NULL) {
Tcl_DStringInit(&command);
Tcl_DStringAppend(&command, script, -1);
Tcl_DStringAppendElement(&command, name);
- Tcl_DStringAppend(&command, " ", 1);
- Tcl_DStringAppend(&command, (version != NULL) ? version : "{}",
- -1);
- if (exact) {
- Tcl_DStringAppend(&command, " -exact", 7);
- }
+ AddRequirementsToDString(&command, reqc, reqv);
+
code = Tcl_EvalEx(interp, Tcl_DStringValue(&command),
Tcl_DStringLength(&command), TCL_EVAL_GLOBAL);
Tcl_DStringFree(&command);
@@ -406,7 +564,7 @@ Tcl_PkgRequireEx(
}
if (code == TCL_ERROR) {
Tcl_AddErrorInfo(interp, "\n (\"package unknown\" script)");
- return NULL;
+ return TCL_ERROR;
}
Tcl_ResetResult(interp);
}
@@ -414,38 +572,41 @@ Tcl_PkgRequireEx(
if (pkgPtr->version == NULL) {
Tcl_AppendResult(interp, "can't find package ", name, NULL);
- if (version != NULL) {
- Tcl_AppendResult(interp, " ", version, NULL);
- }
- return NULL;
+ AddRequirementsToResult(interp, reqc, reqv);
+ return TCL_ERROR;
}
/*
* At this point we know that the package is present. Make sure that the
- * provided version meets the current requirement.
+ * provided version meets the current requirements.
*/
- if (version == NULL) {
- if (clientDataPtr) {
- *clientDataPtr = pkgPtr->clientData;
- }
- return pkgPtr->version;
+ if (reqc == 0) {
+ satisfies = 1;
+ } else {
+ CheckVersionAndConvert (interp, pkgPtr->version, &pkgVersionI, NULL);
+ satisfies = AllRequirementsSatisfied (pkgVersionI, reqc, reqv);
+
+ Tcl_Free (pkgVersionI);
}
- result = ComparePkgVersions(pkgPtr->version, version, &satisfies);
- if ((satisfies && !exact) || (result == 0)) {
+
+ if (satisfies) {
if (clientDataPtr) {
*clientDataPtr = pkgPtr->clientData;
}
- return pkgPtr->version;
+ Tcl_SetObjResult (interp, Tcl_NewStringObj (pkgPtr->version, -1));
+ return TCL_OK;
}
+
Tcl_AppendResult(interp, "version conflict for package \"",
- name, "\": have ", pkgPtr->version, ", need ", version, NULL);
- return NULL;
+ name, "\": have ", pkgPtr->version, ", need", NULL);
+ AddRequirementsToResult (interp, reqc, reqv);
+ return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
- *q
+ *
* Tcl_PkgPresent / Tcl_PkgPresentEx --
*
* Checks to see whether the specified package is present. If it is not
@@ -502,6 +663,10 @@ Tcl_PkgPresentEx(
if (hPtr) {
pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
if (pkgPtr->version != NULL) {
+ char* pvi;
+ char* vi;
+ int thisIsMajor;
+
/*
* At this point we know that the package is present. Make sure
* that the provided version meets the current requirement.
@@ -514,7 +679,20 @@ Tcl_PkgPresentEx(
return pkgPtr->version;
}
- result = ComparePkgVersions(pkgPtr->version, version, &satisfies);
+
+ if (CheckVersionAndConvert (interp, pkgPtr->version, &pvi, NULL) != TCL_OK) {
+ return NULL;
+ } else if (CheckVersionAndConvert (interp, version, &vi, NULL) != TCL_OK) {
+ Tcl_Free (pvi);
+ return NULL;
+ }
+
+ result = CompareVersions(pvi, vi, &thisIsMajor);
+ Tcl_Free (pvi);
+ Tcl_Free (vi);
+
+ satisfies = (result == 0) || ((result == 1) && !thisIsMajor);
+
if ((satisfies && !exact) || (result == 0)) {
if (clientDataPtr) {
*clientDataPtr = pkgPtr->clientData;
@@ -563,13 +741,14 @@ Tcl_PackageObjCmd(
Tcl_Obj *CONST objv[]) /* Argument objects. */
{
static CONST char *pkgOptions[] = {
- "forget", "ifneeded", "names", "present", "provide", "require",
- "unknown", "vcompare", "versions", "vsatisfies", NULL
+ "forget", "ifneeded", "names", "prefer", "present",
+ "provide", "require", "unknown", "vcompare", "versions",
+ "vsatisfies", NULL
};
enum pkgOptions {
- PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, PKG_PRESENT,
- PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE,
- PKG_VERSIONS, PKG_VSATISFIES
+ PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, PKG_PREFER, PKG_PRESENT,
+ PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE, PKG_VERSIONS,
+ PKG_VSATISFIES
};
Interp *iPtr = (Interp *) interp;
int optionIndex, exact, i, satisfies;
@@ -580,6 +759,8 @@ Tcl_PackageObjCmd(
Tcl_HashTable *tablePtr;
CONST char *version;
char *argv2, *argv3, *argv4;
+ char* iva = NULL;
+ char* ivb = NULL;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
@@ -618,19 +799,23 @@ Tcl_PackageObjCmd(
}
case PKG_IFNEEDED: {
int length;
+ char* argv3i;
+ char* avi;
+ int res;
if ((objc != 4) && (objc != 5)) {
Tcl_WrongNumArgs(interp, 2, objv, "package version ?script?");
return TCL_ERROR;
}
argv3 = Tcl_GetString(objv[3]);
- if (CheckVersion(interp, argv3) != TCL_OK) {
+ if (CheckVersionAndConvert(interp, argv3, &argv3i, NULL) != TCL_OK) {
return TCL_ERROR;
}
argv2 = Tcl_GetString(objv[2]);
if (objc == 4) {
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
if (hPtr == NULL) {
+ Tcl_Free (argv3i);
return TCL_OK;
}
pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
@@ -638,10 +823,22 @@ Tcl_PackageObjCmd(
pkgPtr = FindPackage(interp, argv2);
}
argv3 = Tcl_GetStringFromObj(objv[3], &length);
- for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL;
- prevPtr = availPtr, availPtr = availPtr->nextPtr) {
- if (ComparePkgVersions(availPtr->version, argv3, NULL) == 0){
+
+ for (availPtr = pkgPtr->availPtr, prevPtr = NULL;
+ availPtr != NULL;
+ prevPtr = availPtr, availPtr = availPtr->nextPtr) {
+
+ if (CheckVersionAndConvert (interp, availPtr->version, &avi, NULL) != TCL_OK) {
+ Tcl_Free (argv3i);
+ return TCL_ERROR;
+ }
+
+ res = CompareVersions(avi, argv3i, NULL);
+ Tcl_Free (avi);
+
+ if (res == 0){
if (objc == 4) {
+ Tcl_Free (argv3i);
Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE);
return TCL_OK;
}
@@ -649,6 +846,8 @@ Tcl_PackageObjCmd(
break;
}
}
+ Tcl_Free (argv3i);
+
if (objc == 4) {
return TCL_OK;
}
@@ -656,6 +855,7 @@ Tcl_PackageObjCmd(
availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail));
availPtr->version = ckalloc((unsigned) (length + 1));
strcpy(availPtr->version, argv3);
+
if (prevPtr == NULL) {
availPtr->nextPtr = pkgPtr->availPtr;
pkgPtr->availPtr = availPtr;
@@ -698,7 +898,7 @@ Tcl_PackageObjCmd(
version = NULL;
if (objc == (4 + exact)) {
version = Tcl_GetString(objv[3 + exact]);
- if (CheckVersion(interp, version) != TCL_OK) {
+ if (CheckVersionAndConvert(interp, version, NULL, NULL) != TCL_OK) {
return TCL_ERROR;
}
} else if ((objc != 3) || exact) {
@@ -732,41 +932,50 @@ Tcl_PackageObjCmd(
return TCL_OK;
}
argv3 = Tcl_GetString(objv[3]);
- if (CheckVersion(interp, argv3) != TCL_OK) {
+ if (CheckVersionAndConvert(interp, argv3, NULL, NULL) != TCL_OK) {
return TCL_ERROR;
}
return Tcl_PkgProvide(interp, argv2, argv3);
case PKG_REQUIRE:
if (objc < 3) {
requireSyntax:
- Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?");
+ Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?requirement...?");
return TCL_ERROR;
}
+
+ version = NULL;
+
argv2 = Tcl_GetString(objv[2]);
if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) {
- exact = 1;
- } else {
- exact = 0;
- }
- version = NULL;
- if (objc == (4 + exact)) {
- version = Tcl_GetString(objv[3 + exact]);
- if (CheckVersion(interp, version) != TCL_OK) {
+ Tcl_Obj* ov;
+ int res;
+
+ if (objc != 5) {
+ goto requireSyntax;
+ }
+
+ version = Tcl_GetString(objv[4]);
+ if (CheckVersionAndConvert(interp, version, NULL, NULL) != TCL_OK) {
return TCL_ERROR;
}
- } else if ((objc != 3) || exact) {
- goto requireSyntax;
- }
- if (exact) {
- argv3 = Tcl_GetString(objv[3]);
- version = Tcl_PkgRequire(interp, argv3, version, exact);
+
+ /* Create a new-style requirement for the exact version. */
+
+ ov = ExactRequirement (version);
+ version = NULL;
+ argv3 = Tcl_GetString(objv[3]);
+
+ Tcl_IncrRefCount (ov);
+ res = Tcl_PkgRequireProc(interp, argv3, 1, &ov, NULL);
+ Tcl_DecrRefCount (ov);
+ return res;
} else {
- version = Tcl_PkgRequire(interp, argv2, version, exact);
- }
- if (version == NULL) {
- return TCL_ERROR;
+ if (CheckAllRequirements (interp, objc-3, objv+3) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ return Tcl_PkgRequireProc(interp, argv2, objc-3, objv+3, NULL);
}
- Tcl_SetObjResult(interp, Tcl_NewStringObj(version, -1));
break;
case PKG_UNKNOWN: {
int length;
@@ -792,6 +1001,34 @@ Tcl_PackageObjCmd(
}
break;
}
+ case PKG_PREFER: {
+ /* See tclInt.h for the enum, just before Interp */
+ static CONST char *pkgPreferOptions[] = {
+ "latest", "stable", NULL
+ };
+
+ if (objc > 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "?latest|stable?");
+ return TCL_ERROR;
+ }
+
+ if (objc == 3) {
+ /* Set value. */
+
+ int new;
+ if (Tcl_GetIndexFromObj(interp, objv[2], pkgPreferOptions, "preference", 0,
+ &new) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ if (new < iPtr->packagePrefer) {
+ iPtr->packagePrefer = new;
+ }
+ }
+ /* Always return current value. */
+ Tcl_SetObjResult(interp, Tcl_NewStringObj (pkgPreferOptions [iPtr->packagePrefer], -1));
+ break;
+ }
case PKG_VCOMPARE:
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "version1 version2");
@@ -799,12 +1036,17 @@ Tcl_PackageObjCmd(
}
argv3 = Tcl_GetString(objv[3]);
argv2 = Tcl_GetString(objv[2]);
- if ((CheckVersion(interp, argv2) != TCL_OK)
- || (CheckVersion(interp, argv3) != TCL_OK)) {
+ if ((CheckVersionAndConvert (interp, argv2, &iva, NULL) != TCL_OK) ||
+ (CheckVersionAndConvert (interp, argv3, &ivb, NULL) != TCL_OK)) {
+ if (iva != NULL) { Tcl_Free (iva); }
+ /* ivb cannot be set in this branch */
return TCL_ERROR;
}
- Tcl_SetObjResult(interp,
- Tcl_NewIntObj(ComparePkgVersions(argv2, argv3, NULL)));
+
+ /* Comparison is done on the internal representation */
+ Tcl_SetObjResult(interp,Tcl_NewIntObj(CompareVersions(iva, ivb, NULL)));
+ Tcl_Free (iva);
+ Tcl_Free (ivb);
break;
case PKG_VERSIONS:
if (objc != 3) {
@@ -821,20 +1063,28 @@ Tcl_PackageObjCmd(
}
}
break;
- case PKG_VSATISFIES:
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 2, objv, "version1 version2");
+ case PKG_VSATISFIES: {
+ char* argv2i = NULL;
+
+ if (objc < 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "version requirement requirement...");
return TCL_ERROR;
}
- argv3 = Tcl_GetString(objv[3]);
+
argv2 = Tcl_GetString(objv[2]);
- if ((CheckVersion(interp, argv2) != TCL_OK)
- || (CheckVersion(interp, argv3) != TCL_OK)) {
+ if ((CheckVersionAndConvert(interp, argv2, &argv2i, NULL) != TCL_OK)) {
+ return TCL_ERROR;
+ } else if (CheckAllRequirements (interp, objc-3, objv+3) != TCL_OK) {
+ Tcl_Free (argv2i);
return TCL_ERROR;
}
- ComparePkgVersions(argv2, argv3, &satisfies);
+
+ satisfies = AllRequirementsSatisfied (argv2i, objc-3, objv+3);
+ Tcl_Free (argv2i);
+
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(satisfies));
break;
+ }
default:
Tcl_Panic("Tcl_PackageObjCmd: bad option index to pkgOptions");
}
@@ -932,9 +1182,11 @@ TclFreePackageInfo(
/*
*----------------------------------------------------------------------
*
- * CheckVersion --
+ * CheckVersionAndConvert --
*
- * This function checks to see whether a version number has valid syntax.
+ * This function checks to see whether a version number has valid
+ * syntax. It also generates a semi-internal representation (string
+ * rep of a list of numbers).
*
* Results:
* If string is a properly formed version number the TCL_OK is returned.
@@ -948,30 +1200,82 @@ TclFreePackageInfo(
*/
static int
-CheckVersion(
- Tcl_Interp *interp, /* Used for error reporting. */
- CONST char *string) /* Supposedly a version number, which is
- * groups of decimal digits separated by
- * dots. */
+CheckVersionAndConvert(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ CONST char *string, /* Supposedly a version number, which is
+ * groups of decimal digits separated by
+ * dots. */
+ char** internal, /* Internal normalized representation */
+ int* stable) /* Flag: Version is (un)stable. */
{
CONST char *p = string;
char prevChar;
+ int hasunstable = 0;
+ /* 4* assuming that each char is a separator (a,b become ' -x ').
+ * 4+ to have spce for an additional -2 at the end
+ */
+ char* ibuf = Tcl_Alloc (4+4*strlen(string));
+ char* ip = ibuf;
+
+ /* Basic rules
+ * (1) First character has to be a digit.
+ * (2) All other characters have to be a digit or '.'
+ * (3) Two '.'s may not follow each other.
+
+ * TIP 268, Modified rules
+ * (1) s.a.
+ * (2) All other characters have to be a digit, 'a', 'b', or '.'
+ * (3) s.a.
+ * (4) Only one of 'a' or 'b' may occur.
+ * (5) Neither 'a', nor 'b' may occur before or after a '.'
+ */
if (!isdigit(UCHAR(*p))) { /* INTL: digit */
goto error;
}
+
+ *ip++ = *p;
+
for (prevChar = *p, p++; *p != 0; p++) {
- if (!isdigit(UCHAR(*p)) &&
- ((*p != '.') || (prevChar == '.'))) { /* INTL: digit */
+ if (
+ (!isdigit(UCHAR(*p))) &&
+ (((*p != '.') && (*p != 'a') && (*p != 'b')) ||
+ ((hasunstable && ((*p == 'a') || (*p == 'b'))) ||
+ (((prevChar == 'a') || (prevChar == 'b') || (prevChar == '.')) && (*p == '.')) ||
+ (((*p == 'a') || (*p == 'b') || (*p == '.')) && (prevChar == '.'))))
+ ) {
+ /* INTL: digit */
goto error;
}
+
+ if ((*p == 'a') || (*p == 'b')) { hasunstable = 1 ; }
+
+ /* Translation to the internal rep. Regular version chars are copied
+ * as is. The separators are translated to numerics. The new separator
+ * for all parts is space. */
+
+ if (*p == '.') { *ip++ = ' '; *ip++ = '0'; *ip++ = ' '; }
+ else if (*p == 'a') { *ip++ = ' '; *ip++ = '-'; *ip++ = '2'; *ip++ = ' '; }
+ else if (*p == 'b') { *ip++ = ' '; *ip++ = '-'; *ip++ = '1'; *ip++ = ' '; }
+ else { *ip++ = *p; }
+
prevChar = *p;
}
- if (prevChar != '.') {
+ if ((prevChar != '.') && (prevChar != 'a') && (prevChar != 'b')) {
+ *ip = '\0';
+ if (internal != NULL) {
+ *internal = ibuf;
+ } else {
+ Tcl_Free (ibuf);
+ }
+ if (stable != NULL) {
+ *stable = !hasunstable;
+ }
return TCL_OK;
}
error:
+ Tcl_Free (ibuf);
Tcl_AppendResult(interp, "expected version number but got \"", string,
"\"", NULL);
return TCL_ERROR;
@@ -980,9 +1284,9 @@ CheckVersion(
/*
*----------------------------------------------------------------------
*
- * ComparePkgVersions --
+ * CompareVersions --
*
- * This function compares two version numbers.
+ * This function compares two version numbers (in internal rep).
*
* Results:
* The return value is -1 if v1 is less than v2, 0 if the two version
@@ -997,22 +1301,30 @@ CheckVersion(
*/
static int
-ComparePkgVersions(
- CONST char *v1,
- CONST char *v2, /* Versions strings, of form 2.1.3 (any number
- * of version numbers). */
- int *satPtr) /* If non-null, the word pointed to is filled
- * in with a 0/1 value. 1 means v1 "satisfies"
- * v2: v1 is greater than or equal to v2 and
- * both version numbers have the same major
- * number. */
+CompareVersions(
+ CONST char *v1, /* Versions strings, of form 2.1.3 (any number */
+ CONST char *v2, /* of version numbers). */
+ int *isMajorPtr) /* If non-null, the word pointed to is filled
+ * in with a 0/1 value. 1 means that the difference
+ * occured in the first element. */
{
int thisIsMajor, n1, n2;
+ int res, flip;
/*
* Each iteration of the following loop processes one number from each
- * string, terminated by a ".". If those numbers don't match then the
+ * string, terminated by a " " (space). If those numbers don't match then the
* comparison is over; otherwise, we loop back for the next number.
+ *
+ * TIP 268.
+ * This is identical the function 'ComparePkgVersion', but using the new
+ * space separator as used by the internal rep of version numbers. The
+ * special separators 'a' and 'b' have already been dealt with in
+ * 'CheckVersionAndConvert', they were translated into numbers as
+ * well. This keeps the comparison sane. Otherwise we would have to
+ * compare numerics, the separators, and also deal with the special case
+ * of end-of-string compared to separators. The semi-list rep we get here
+ * is much easier to handle, as it is still regular.
*/
thisIsMajor = 1;
@@ -1022,14 +1334,20 @@ ComparePkgVersions(
*/
n1 = n2 = 0;
- while ((*v1 != 0) && (*v1 != '.')) {
+ flip = 0;
+ while ((*v1 != 0) && (*v1 != ' ')) {
+ if (*v1 == '-') {flip = 1 ; v1++ ; continue;}
n1 = 10*n1 + (*v1 - '0');
v1++;
}
- while ((*v2 != 0) && (*v2 != '.')) {
+ if (flip) n1 = -n1;
+ flip = 0;
+ while ((*v2 != 0) && (*v2 != ' ')) {
+ if (*v2 == '-') {flip = 1; v2++ ; continue;}
n2 = 10*n2 + (*v2 - '0');
v2++;
}
+ if (flip) n2 = -n2;
/*
* Compare and go on to the next version number if the current numbers
@@ -1049,15 +1367,424 @@ ComparePkgVersions(
}
thisIsMajor = 0;
}
- if (satPtr != NULL) {
- *satPtr = (n1 == n2) || ((n1 > n2) && !thisIsMajor);
- }
+
if (n1 > n2) {
- return 1;
+ res = 1;
} else if (n1 == n2) {
- return 0;
+ res = 0;
+ } else {
+ res = -1;
+ }
+
+ if (isMajorPtr != NULL) {
+ *isMajorPtr = thisIsMajor;
+ }
+
+ return res;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CheckAllRequirements --
+ *
+ * This function checks to see whether all requirements in a set
+ * have valid syntax.
+ *
+ * Results:
+ * TCL_OK is returned if all requirements are valid.
+ * Otherwise TCL_ERROR is returned and an error message
+ * is left in the interp's result.
+ *
+ * Side effects:
+ * May modify the interpreter result.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CheckAllRequirements(
+ Tcl_Interp* interp,
+ int reqc, /* Requirements to check. */
+ Tcl_Obj *CONST reqv[])
+{
+ int i;
+ for (i = 0; i < reqc; i++) {
+ if ((CheckRequirement(interp, Tcl_GetString(reqv[i])) != TCL_OK)) {
+ return TCL_ERROR;
+ }
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CheckRequirement --
+ *
+ * This function checks to see whether a requirement has valid syntax.
+ *
+ * Results:
+ * If string is a properly formed requirement then TCL_OK is returned.
+ * Otherwise TCL_ERROR is returned and an error message is left in the
+ * interp's result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CheckRequirement(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ CONST char *string) /* Supposedly a requirement. */
+{
+ /* Syntax of requirement = version
+ * = version-version
+ * = version-
+ */
+
+ char* dash = NULL;
+ char* buf;
+
+ dash = strchr (string, '-');
+ if (dash == NULL) {
+ /* no dash found, has to be a simple version */
+ return CheckVersionAndConvert (interp, string, NULL, NULL);
+ }
+ if (strchr (dash+1, '-') != NULL) {
+ /* More dashes found after the first. This is wrong. */
+ Tcl_AppendResult(interp, "expected versionMin-versionMax but got \"", string,
+ "\"", NULL);
+ return TCL_ERROR;
+ }
+
+ /* Exactly one dash is present. Copy the string, split at the location of
+ * dash and check that both parts are versions. Note that the max part can
+ * be empty.
+ */
+
+ buf = strdup (string);
+ dash = buf + (dash - string);
+ *dash = '\0'; /* buf now <=> min part */
+ dash ++; /* dash now <=> max part */
+
+ if ((CheckVersionAndConvert(interp, buf, NULL, NULL) != TCL_OK) ||
+ ((*dash != '\0') &&
+ (CheckVersionAndConvert(interp, dash, NULL, NULL) != TCL_OK))) {
+ free (buf);
+ return TCL_ERROR;
+ }
+
+ free (buf);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * AddRequirementsToResult --
+ *
+ * This function accumulates requirements in the interpreter result.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The interpreter result is extended.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+AddRequirementsToResult(
+ Tcl_Interp* interp,
+ int reqc, /* Requirements constraining the desired version. */
+ Tcl_Obj *CONST reqv[]) /* 0 means to use the latest version available. */
+{
+ if (reqc > 0) {
+ int i;
+ for (i = 0; i < reqc; i++) {
+ Tcl_AppendResult(interp, " ", TclGetString(reqv[i]), NULL);
+ }
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * AddRequirementsToDString --
+ *
+ * This function accumulates requirements in a DString.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The DString argument is extended.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+AddRequirementsToDString(
+ Tcl_DString* dstring,
+ int reqc, /* Requirements constraining the desired version. */
+ Tcl_Obj *CONST reqv[]) /* 0 means to use the latest version available. */
+{
+ if (reqc > 0) {
+ int i;
+ for (i = 0; i < reqc; i++) {
+ Tcl_DStringAppend(dstring, " ", 1);
+ Tcl_DStringAppend(dstring, TclGetString(reqv[i]), -1);
+ }
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * AllRequirementSatisfied --
+ *
+ * This function checks to see whether a version satisfies at
+ * least one of a set of requirements.
+ *
+ * Results:
+ * If the requirements are satisfied 1 is returned.
+ * Otherwise 0 is returned. The function assumes
+ * that all pieces have valid syntax. And is allowed
+ * to make that assumption.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+AllRequirementsSatisfied(
+ CONST char* availVersionI, /* Candidate version to check against the requirements */
+ int reqc, /* Requirements constraining the desired version. */
+ Tcl_Obj *CONST reqv[]) /* 0 means to use the latest version available. */
+{
+ int i, satisfies;
+
+ for (satisfies = i = 0; i < reqc; i++) {
+ satisfies = RequirementSatisfied(availVersionI, Tcl_GetString(reqv[i]));
+ if (satisfies) break;
+ }
+ return satisfies;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * RequirementSatisfied --
+ *
+ * This function checks to see whether a version satisfies a requirement.
+ *
+ * Results:
+ * If the requirement is satisfied 1 is returned.
+ * Otherwise 0 is returned. The function assumes
+ * that all pieces have valid syntax. And is allowed
+ * to make that assumption.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+RequirementSatisfied(
+ CONST char *havei, /* Version string, of candidate package we have */
+ CONST char *req) /* Requirement string the candidate has to satisfy */
+{
+ /* The have candidate is already in internal rep. */
+
+ int satisfied, res;
+ char* dash = NULL;
+ char* buf, *min, *max;
+
+ dash = strchr (req, '-');
+ if (dash == NULL) {
+ /* No dash found, is a simple version, fallback to regular check.
+ * The 'CheckVersionAndConvert' cannot fail. We pad the requirement with
+ * 'a0', i.e '-2' before doing the comparison to properly accept
+ * unstables as well.
+ */
+
+ char* reqi = NULL;
+ int thisIsMajor;
+
+ CheckVersionAndConvert (NULL, req, &reqi, NULL);
+ strcat (reqi, " -2");
+ res = CompareVersions(havei, reqi, &thisIsMajor);
+ satisfied = (res == 0) || ((res == 1) && !thisIsMajor);
+ Tcl_Free (reqi);
+ return satisfied;
+ }
+
+ /* Exactly one dash is present (Assumption of valid syntax). Copy the req,
+ * split at the location of dash and check that both parts are
+ * versions. Note that the max part can be empty.
+ */
+
+ buf = strdup (req);
+ dash = buf + (dash - req);
+ *dash = '\0'; /* buf now <=> min part */
+ dash ++; /* dash now <=> max part */
+
+ if (*dash == '\0') {
+ /* We have a min, but no max. For the comparison we generate the
+ * internal rep, padded with 'a0' i.e. '-2'.
+ */
+
+ /* No max part, unbound */
+
+ CheckVersionAndConvert (NULL, buf, &min, NULL);
+ strcat (min, " -2");
+ satisfied = (CompareVersions(havei, min, NULL) >= 0);
+ Tcl_Free (min);
+ free (buf);
+ return satisfied;
+ }
+
+ /* We have both min and max, and generate their internal reps.
+ * When identical we compare as is, otherwise we pad with 'a0'
+ * to ove the range a bit.
+ */
+
+ CheckVersionAndConvert (NULL, buf, &min, NULL);
+ CheckVersionAndConvert (NULL, dash, &max, NULL);
+
+ if (CompareVersions(min, max, NULL) == 0) {
+ satisfied = (CompareVersions(min, havei, NULL) == 0);
} else {
- return -1;
+ strcat (min, " -2");
+ strcat (max, " -2");
+ satisfied = ((CompareVersions(min, havei, NULL) <= 0) &&
+ (CompareVersions(havei, max, NULL) < 0));
+ }
+
+ Tcl_Free (min);
+ Tcl_Free (max);
+ free (buf);
+ return satisfied;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ExactRequirement --
+ *
+ * This function is the core for the translation of -exact requests.
+ * It translates the request of the version into a range of versions.
+ * The translation was chosen for backwards compatibility.
+ *
+ * Results:
+ * A Tcl_Obj containing the version range as string.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Tcl_Obj*
+ExactRequirement(version)
+ CONST char* version;
+{
+ /* A -exact request for a version X.y is translated into the range
+ * X.y-X.(y+1). For example -exact 8.4 means the range "8.4-8.5".
+ *
+ * This translation was chosen to prevent packages which currently use a
+ * 'package require -exact tclversion' from being affected by the core now
+ * registering itself as 8.4.x (patchlevel) instead of 8.4
+ * (version). Examples are tbcload, compiler, and ITcl.
+ *
+ * Translating -exact 8.4 to the range "8.4-8.4" instead would require us
+ * and everyone else to rebuild these packages to require -exact 8.4.14,
+ * or whatever the exact current patchlevel is. A backward compatibility
+ * issue with effects similar to the bugfix made in 8.5 now requiring
+ * ifneeded and provided versions to match. Instead we have chosen to
+ * interpret exactness to not be exactly equal, but to be exact only
+ * within the specified level, and allowing variation in the deeper
+ * level. More examples:
+ *
+ * -exact 8 => "8-9"
+ * -exact 8.4 => "8.4-8.5"
+ * -exact 8.4.14 => "8.4.14-8.4.15"
+ * -exact 8.0a2 => "8.0a2-8.0a3"
+ */
+
+ char* iv;
+ int lc, i;
+ CONST char** lv;
+ char buf [30];
+ Tcl_Obj* o = Tcl_NewStringObj (version,-1);
+ Tcl_AppendStringsToObj (o, "-", NULL);
+
+ /* Assuming valid syntax here */
+ CheckVersionAndConvert (NULL, version, &iv, NULL);
+
+ /* Split the list into components */
+ Tcl_SplitList (NULL, iv, &lc, &lv);
+
+ /* Iterate over the components and make them parts of the result. Except
+ * for the last, which is handled separately, to allow the
+ * incrementation.
+ */
+
+ for (i=0; i < (lc-1); i++) {
+ /* Regular component */
+ Tcl_AppendStringsToObj (o, lv[i], NULL);
+ /* Separator component */
+ i ++;
+ if (0 == strcmp ("-1", lv[i])) {
+ Tcl_AppendStringsToObj (o, "b", NULL);
+ } else if (0 == strcmp ("-2", lv[i])) {
+ Tcl_AppendStringsToObj (o, "a", NULL);
+ } else {
+ Tcl_AppendStringsToObj (o, ".", NULL);
+ }
+ }
+ /* Regular component, last */
+ sprintf (buf, "%d", atoi (lv [lc-1]) + 1);
+ Tcl_AppendStringsToObj (o, buf, NULL);
+
+ ckfree ((char*) lv);
+ return o;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * VersionCleanupProc --
+ *
+ * This function is called to delete the last remember package version
+ * string for an interpreter when the interpreter is deleted. It gets
+ * invoked via the Tcl AssocData mechanism.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Storage for the version object for interp get deleted.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+VersionCleanupProc (
+ ClientData clientData, /* Pointer to remembered version string object
+ * for interp. */
+ Tcl_Interp *interp) /* Interpreter that is being deleted. */
+{
+ Tcl_Obj* ov = (Tcl_Obj*) clientData;
+ if (ov != NULL) {
+ Tcl_DecrRefCount (ov);
}
}
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 9d52015..4a68100 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclStubInit.c,v 1.131 2006/06/21 03:10:39 dgp Exp $
+ * RCS: @(#) $Id: tclStubInit.c,v 1.132 2006/09/22 18:13:29 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -1070,6 +1070,7 @@ TclStubs tclStubs = {
Tcl_GetEncodingSearchPath, /* 570 */
Tcl_SetEncodingSearchPath, /* 571 */
Tcl_GetEncodingNameFromEnvironment, /* 572 */
+ Tcl_PkgRequireProc, /* 573 */
};
/* !END!: Do not edit above this line. */
diff --git a/generic/tclTest.c b/generic/tclTest.c
index d05e9f2..2e0f4ae 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -14,7 +14,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclTest.c,v 1.104 2006/06/21 20:44:59 das Exp $
+ * RCS: @(#) $Id: tclTest.c,v 1.105 2006/09/22 18:13:29 andreas_kupries Exp $
*/
#define TCL_TEST
@@ -560,7 +560,9 @@ Tcltest_Init(
"-appinitprocclosestderr", "-appinitprocsetrcfile", NULL
};
- if (Tcl_PkgProvide(interp, "Tcltest", TCL_VERSION) == TCL_ERROR) {
+ /* TIP #268: Full patchlevel instead of just major.minor */
+
+ if (Tcl_PkgProvide(interp, "Tcltest", TCL_PATCH_LEVEL) == TCL_ERROR) {
return TCL_ERROR;
}
diff --git a/generic/tclTomMathInterface.c b/generic/tclTomMathInterface.c
index 65eddcf..f726531 100644
--- a/generic/tclTomMathInterface.c
+++ b/generic/tclTomMathInterface.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclTomMathInterface.c,v 1.6 2005/12/13 22:43:18 kennykb Exp $
+ * RCS: @(#) $Id: tclTomMathInterface.c,v 1.7 2006/09/22 18:13:29 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -42,7 +42,9 @@ int
TclTommath_Init(
Tcl_Interp* interp /* Tcl interpreter */
) {
- if (Tcl_PkgProvideEx(interp, "tcl::tommath", TCL_VERSION,
+ /* TIP #268: Full patchlevel instead of just major.minor */
+
+ if (Tcl_PkgProvideEx(interp, "tcl::tommath", TCL_PATCH_LEVEL,
(ClientData)&tclTomMathStubs) != TCL_OK) {
return TCL_ERROR;
}
diff --git a/library/init.tcl b/library/init.tcl
index c67a6e9..e5a86be 100644
--- a/library/init.tcl
+++ b/library/init.tcl
@@ -3,7 +3,7 @@
# Default system startup file for Tcl-based applications. Defines
# "unknown" procedure and auto-load facilities.
#
-# RCS: @(#) $Id: init.tcl,v 1.85 2006/02/08 21:41:28 dgp Exp $
+# RCS: @(#) $Id: init.tcl,v 1.86 2006/09/22 18:13:29 andreas_kupries Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
@@ -17,7 +17,7 @@
if {[info commands package] == ""} {
error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]"
}
-package require -exact Tcl 8.5
+package require -exact Tcl 8.5a5
# Compute the auto path to use in this interpreter.
# The values on the path come from several locations:
diff --git a/library/package.tcl b/library/package.tcl
index 9d9e0a9..bd3ecf6 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.33 2005/07/23 04:12:49 dgp Exp $
+# RCS: @(#) $Id: package.tcl,v 1.34 2006/09/22 18:13:29 andreas_kupries Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1998 Sun Microsystems, Inc.
@@ -459,7 +459,7 @@ 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 {name args} {
global auto_path env
if {![info exists auto_path]} {
@@ -555,10 +555,10 @@ proc tclPkgUnknown {name version {exact {}}} {
# version - Version of desired package. Not used.
# exact - Either "-exact" or omitted. Not used.
-proc tcl::MacOSXPkgUnknown {original name version {exact {}}} {
+proc tcl::MacOSXPkgUnknown {original name args} {
# First do the cross-platform default search
- uplevel 1 $original [list $name $version $exact]
+ uplevel 1 $original [linsert $args 0 $name]
# Now do MacOSX specific searching
global auto_path
diff --git a/library/tm.tcl b/library/tm.tcl
index db1f361..b877cbb 100644
--- a/library/tm.tcl
+++ b/library/tm.tcl
@@ -189,7 +189,7 @@ proc ::tcl::tm::list {} {
# May populate the package ifneeded database with additional
# provide scripts.
-proc ::tcl::tm::UnknownHandler {original name version {exact {}}} {
+proc ::tcl::tm::UnknownHandler {original name args} {
# Import the list of paths to search for packages in module form.
# Import the pattern used to check package names in detail.
@@ -263,10 +263,8 @@ proc ::tcl::tm::UnknownHandler {original name version {exact {}}} {
# processing.
if {
- $pkgname eq $name && (
- ($exact eq "-exact" && ![package vcompare $pkgversion $version]) ||
- ($version ne "" && [package vsatisfies $pkgversion $version]) ||
- ($version eq ""))
+ ($pkgname eq $name) &&
+ [package vsatisfies $pkgversion {expand}$args]
} then {
set satisfied 1
# We do not abort the loop, and keep adding
@@ -287,7 +285,7 @@ proc ::tcl::tm::UnknownHandler {original name version {exact {}}} {
# about ::list...
if {[llength $original]} {
- uplevel 1 $original [::list $name $version $exact]
+ uplevel 1 $original [::linsert $args 0 $name]
}
}
diff --git a/tests/pkg.test b/tests/pkg.test
index 31091bb..5f78f2f 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.16 2005/12/02 17:34:03 dgp Exp $
+# RCS: @(#) $Id: pkg.test,v 1.17 2006/09/22 18:13:30 andreas_kupries Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
@@ -56,6 +56,23 @@ test pkg-1.5 {Tcl_PkgProvide procedure} {
package provide t 2.3
} {}
+test pkg-1.6 {Tcl_PkgProvide procedure} {
+ 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} {
+ 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} {
@@ -124,7 +141,7 @@ test pkg-2.8 {Tcl_PkgRequire procedure, can't find suitable version} {
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 {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 {}
@@ -155,9 +172,11 @@ test pkg-2.12 {Tcl_PkgRequire procedure, self-deleting script} {
} {1.2}
test pkg-2.13 {Tcl_PkgRequire procedure, "package unknown" support} {
proc pkgUnknown args {
+ # args = name requirement
+ # requirement = v-v (for exact version)
global x
set x $args
- package provide [lindex $args 0] [lindex $args 1]
+ 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} {
@@ -168,7 +187,7 @@ test pkg-2.13 {Tcl_PkgRequire procedure, "package unknown" support} {
package require -exact t 1.5
package unknown {}
set x
-} {t 1.5 -exact}
+} {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"
@@ -192,7 +211,7 @@ test pkg-2.15 {Tcl_PkgRequire procedure, "package unknown" support} {
package require {a b}
package unknown {}
set x
-} {{a b} {}}
+} {{a b}}
test pkg-2.16 {Tcl_PkgRequire procedure, "package unknown" error} {
proc pkgUnknown args {
error "testing package unknown"
@@ -207,7 +226,7 @@ test pkg-2.16 {Tcl_PkgRequire procedure, "package unknown" error} {
"error "testing package unknown""
(procedure "pkgUnknown" line 2)
invoked from within
-"pkgUnknown t {}"
+"pkgUnknown t"
("package unknown" script)
invoked from within
"package require t"}}
@@ -225,7 +244,7 @@ test pkg-2.17 {Tcl_PkgRequire procedure, "package unknown" doesn't load package}
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} {t 1.5 -exact}}
+} {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
@@ -260,7 +279,7 @@ test pkg-2.24 {Tcl_PkgRequire procedure, version checks} {
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}}
+} {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}
@@ -463,6 +482,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} {
+ 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} {
+ 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} {
+ 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 ...?"}}
@@ -588,16 +641,14 @@ test pkg-3.21 {Tcl_PackageCmd procedure, "provide" option} {
} {1 {expected version number but got "a.b"}}
test pkg-3.22 {Tcl_PackageCmd procedure, "require" option} {
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} {
- list [catch {package require a b c} msg] $msg
-} {1 {wrong # args: should be "package require ?-exact? package ?version?"}}
+} {1 {wrong # args: should be "package require ?-exact? package ?requirement...?"}}
+
test pkg-3.24 {Tcl_PackageCmd procedure, "require" option} {
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} {
- list [catch {package require -bs a b} msg] $msg
-} {1 {wrong # args: should be "package require ?-exact? package ?version?"}}
+ # Exact syntax: -exact name version
+ # name ?requirement...?
+} {1 {wrong # args: should be "package require ?-exact? package ?requirement...?"}}
+
test pkg-3.26 {Tcl_PackageCmd procedure, "require" option} {
list [catch {package require x a.b} msg] $msg
} {1 {expected version number but got "a.b"}}
@@ -606,10 +657,10 @@ test pkg-3.27 {Tcl_PackageCmd procedure, "require" option} {
} {1 {expected version number but got "a.b"}}
test pkg-3.28 {Tcl_PackageCmd procedure, "require" option} {
list [catch {package require -exact x} msg] $msg
-} {1 {wrong # args: should be "package require ?-exact? package ?version?"}}
+} {1 {wrong # args: should be "package require ?-exact? package ?requirement...?"}}
test pkg-3.29 {Tcl_PackageCmd procedure, "require" option} {
list [catch {package require -exact} msg] $msg
-} {1 {wrong # args: should be "package require ?-exact? package ?version?"}}
+} {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
@@ -677,10 +728,8 @@ test pkg-3.46 {Tcl_PackageCmd procedure, "versions" option} {
} {2.3 2.4}
test pkg-3.47 {Tcl_PackageCmd procedure, "vsatisfies" option} {
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} {
- list [catch {package vsatisfies a b c} msg] $msg
-} {1 {wrong # args: should be "package vsatisfies version1 version2"}}
+} {1 {wrong # args: should be "package vsatisfies version requirement requirement..."}}
+
test pkg-3.49 {Tcl_PackageCmd procedure, "vsatisfies" option} {
list [catch {package vsatisfies x.y 3.4} msg] $msg
} {1 {expected version number but got "x.y"}}
@@ -695,7 +744,20 @@ test pkg-3.52 {Tcl_PackageCmd procedure, "vsatisfies" option} {
} {0}
test pkg-3.53 {Tcl_PackageCmd procedure, "versions" option} {
list [catch {package foo} msg] $msg
-} {1 {bad option "foo": must be forget, ifneeded, names, present, provide, require, unknown, vcompare, versions, or vsatisfies}}
+} {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} {
+ 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} {
+ 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} {
+ 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.
@@ -842,6 +904,281 @@ 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} {
+ package vsatisfies $p $r
+ } $vs
+
+ test package-vcompare-1.$n {package vcompare} {
+ 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" {
+ package vsatisfies $provided $required
+ } $satisfied
+ incr n
+}
+
+test package-vsatisfies-3.0 "package vsatisfies multiple" {
+ # yes no
+ package vsatisfies 8.4 8.4 7.3
+} 1
+
+test package-vsatisfies-3.1 "package vsatisfies multiple" {
+ # no yes
+ package vsatisfies 8.4 7.3 8.4
+} 1
+
+test package-vsatisfies-3.2 "package vsatisfies multiple" {
+ # yes yes
+ package vsatisfies 8.4.2 8.4 8.4.1
+} 1
+
+test package-vsatisfies-3.3 "package vsatisfies multiple" {
+ # 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} {
+ prefer
+} stable
+
+test package-prefer-1.1 {default} {
+ 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} {
+ catch {package prefer foo bar} msg
+ set msg
+} {wrong # args: should be "package prefer ?latest|stable?"}
+
+test package-prefer-2.1 {bogus argument} {
+ catch {package prefer foo} msg
+ set msg
+} {bad preference "foo": must be latest or stable}
+
+test package-prefer-3.0 {set, keep} {
+ package prefer stable
+} stable
+
+test package-prefer-3.1 {set stable, keep} {
+ prefer stable
+} {stable stable}
+
+test package-prefer-3.2 {set latest, change} {
+ prefer latest
+} {stable latest}
+
+test package-prefer-3.3 {set latest, keep} {
+ prefer latest latest
+} {stable latest latest}
+
+test package-prefer-3.3 {set stable, rejected} {
+ prefer latest stable
+} {stable latest latest}
+
+rename prefer {}
+
+
set auto_path $oldPath
package unknown $oldPkgUnknown
concat
generated by cgit v0.12 at 2024-11-17 15:01:42 (GMT)