summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authorandreas_kupries <akupries@shaw.ca>2006-09-22 18:13:25 (GMT)
committerandreas_kupries <akupries@shaw.ca>2006-09-22 18:13:25 (GMT)
commit4d806ec7125d35e4f837f3a2274aedc0f7593954 (patch)
treef67d58798c4d5ba6ee60a07d1f99fe77001dee13 /generic
parent881fdb141e92e3ea0b7b72197ad32d992f78195c (diff)
downloadtcl-4d806ec7125d35e4f837f3a2274aedc0f7593954.zip
tcl-4d806ec7125d35e4f837f3a2274aedc0f7593954.tar.gz
tcl-4d806ec7125d35e4f837f3a2274aedc0f7593954.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:
Diffstat (limited to 'generic')
-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
9 files changed, 930 insertions, 149 deletions
diff --git a/generic/tcl.decls b/generic/tcl.decls
index e19db3f..189bcaf 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -11,7 +11,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: tcl.decls,v 1.120 2006/02/08 21:41:27 dgp Exp $
+# RCS: @(#) $Id: tcl.decls,v 1.121 2006/09/22 18:13:27 andreas_kupries Exp $
library tcl
@@ -971,6 +971,7 @@ declare 273 generic {
int Tcl_PkgProvide(Tcl_Interp *interp, CONST char *name,
CONST char *version)
}
+# TIP #268: The internally used new Require function is in slot 573.
declare 274 generic {
CONST84_RETURN char * Tcl_PkgRequire(Tcl_Interp *interp, CONST char *name,
CONST char *version, int exact)
@@ -1989,7 +1990,7 @@ declare 554 generic {
Tcl_DriverThreadActionProc *Tcl_ChannelThreadActionProc(Tcl_ChannelType *chanTypePtr)
}
-# TIP #237:
+# TIP#237 (Arbitrary-precision Integers) kevin kenny
declare 555 generic {
Tcl_Obj* Tcl_NewBignumObj( mp_int* value )
@@ -2007,7 +2008,7 @@ declare 559 generic {
int Tcl_GetBignumAndClearObj( Tcl_Interp* interp, Tcl_Obj* obj, mp_int* value )
}
-# TIP #208:
+# TIP #208 ('chan' Command) jeffh
declare 560 generic {
int Tcl_TruncateChannel(Tcl_Channel chan, Tcl_WideInt length)
}
@@ -2031,14 +2032,14 @@ declare 565 generic {
void Tcl_GetChannelError (Tcl_Channel chan, Tcl_Obj** msg)
}
-# Additional conversion functions for bignum support
+# TIP #237 (Additional conversion functions for bignum support)
declare 566 generic {
int Tcl_InitBignumFromDouble(Tcl_Interp* interp, double initval,
mp_int *toInit)
}
-# TIP 181
+# TIP#181 (namespace unknown Command)
declare 567 generic {
Tcl_Obj *Tcl_GetNamespaceUnknownHandler(Tcl_Interp *interp,
Tcl_Namespace *nsPtr)
@@ -2049,7 +2050,7 @@ declare 568 generic {
Tcl_Obj *handlerPtr)
}
-# TIP#258 Enhanced Interface for Encodings
+# TIP#258 (Enhanced Interface for Encodings)
declare 569 generic {
int Tcl_GetEncodingFromObj(Tcl_Interp* interp, Tcl_Obj* objPtr,
@@ -2065,6 +2066,12 @@ declare 572 generic {
CONST char *Tcl_GetEncodingNameFromEnvironment(Tcl_DString* bufPtr)
}
+# TIP#268: Extended version numbers and requirements
+declare 573 generic {
+ int Tcl_PkgRequireProc(Tcl_Interp *interp, CONST char *name,
+ int objc, Tcl_Obj *CONST objv[], ClientData *clientDataPtr)
+}
+
##############################################################################
# Define the platform specific public Tcl interface. These functions are
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 1c3eb2c..c931281 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclBasic.c,v 1.196 2006/08/30 19:33:11 hobbs Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.197 2006/09/22 18:13:27 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -326,6 +326,12 @@ Tcl_CreateInterp(void)
Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS);
iPtr->packageUnknown = NULL;
+
+ /* TIP #268 */
+ iPtr->packagePrefer = (getenv ("TCL_PKG_PREFER_LATEST") == NULL ?
+ PKG_PREFER_STABLE :
+ PKG_PREFER_LATEST);
+
iPtr->cmdCount = 0;
TclInitLiteralTable(&(iPtr->literalTable));
iPtr->compileEpoch = 0;
@@ -562,9 +568,10 @@ Tcl_CreateInterp(void)
/*
* Register Tcl's version number.
+ * TIP #268: Full patchlevel instead of just major.minor
*/
- Tcl_PkgProvideEx(interp, "Tcl", TCL_VERSION, (ClientData) &tclStubs);
+ Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, (ClientData) &tclStubs);
#ifdef Tcl_InitStubs
#undef Tcl_InitStubs
diff --git a/generic/tclConfig.c b/generic/tclConfig.c
index 756b396..c65c501 100644
--- a/generic/tclConfig.c
+++ b/generic/tclConfig.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclConfig.c,v 1.10 2005/11/01 15:30:52 dkf Exp $
+ * RCS: @(#) $Id: tclConfig.c,v 1.11 2006/09/22 18:13:28 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -68,14 +68,18 @@ Tcl_RegisterConfig(
CONST char *valEncoding) /* Name of the encoding used to store the
* configuration values, ASCII, thus UTF-8. */
{
- Tcl_Encoding venc = Tcl_GetEncoding(NULL, valEncoding);
- Tcl_Obj *pDB = GetConfigDict(interp);
- Tcl_Obj *pkg = Tcl_NewStringObj(pkgName, -1);
+ Tcl_Encoding venc;
+ Tcl_Obj *pDB;
+ Tcl_Obj *pkg;
Tcl_Obj *pkgDict;
Tcl_DString cmdName;
Tcl_Config *cfg;
int res;
+ venc = Tcl_GetEncoding(NULL, valEncoding);
+ pDB = GetConfigDict(interp);
+ pkg = Tcl_NewStringObj(pkgName, -1);
+
/*
* Phase I: Adding the provided information to the internal database of
* package meta data.
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index 00f009f..35776db 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclDecls.h,v 1.122 2006/02/08 21:41:27 dgp Exp $
+ * RCS: @(#) $Id: tclDecls.h,v 1.123 2006/09/22 18:13:28 andreas_kupries Exp $
*/
#ifndef _TCLDECLS
@@ -3571,6 +3571,14 @@ EXTERN int Tcl_SetEncodingSearchPath _ANSI_ARGS_((
EXTERN CONST char * Tcl_GetEncodingNameFromEnvironment _ANSI_ARGS_((
Tcl_DString* bufPtr));
#endif
+#ifndef Tcl_PkgRequireProc_TCL_DECLARED
+#define Tcl_PkgRequireProc_TCL_DECLARED
+/* 573 */
+EXTERN int Tcl_PkgRequireProc _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * name, int objc,
+ Tcl_Obj *CONST objv[],
+ ClientData * clientDataPtr));
+#endif
typedef struct TclStubHooks {
struct TclPlatStubs *tclPlatStubs;
@@ -4185,6 +4193,7 @@ typedef struct TclStubs {
Tcl_Obj* (*tcl_GetEncodingSearchPath) _ANSI_ARGS_((void)); /* 570 */
int (*tcl_SetEncodingSearchPath) _ANSI_ARGS_((Tcl_Obj* searchPath)); /* 571 */
CONST char * (*tcl_GetEncodingNameFromEnvironment) _ANSI_ARGS_((Tcl_DString* bufPtr)); /* 572 */
+ int (*tcl_PkgRequireProc) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, int objc, Tcl_Obj *CONST objv[], ClientData * clientDataPtr)); /* 573 */
} TclStubs;
#ifdef __cplusplus
@@ -6517,6 +6526,10 @@ extern TclStubs *tclStubsPtr;
#define Tcl_GetEncodingNameFromEnvironment \
(tclStubsPtr->tcl_GetEncodingNameFromEnvironment) /* 572 */
#endif
+#ifndef Tcl_PkgRequireProc
+#define Tcl_PkgRequireProc \
+ (tclStubsPtr->tcl_PkgRequireProc) /* 573 */
+#endif
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 0f34ea5..7b230dc 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInt.h,v 1.275 2006/08/21 01:08:41 das Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.276 2006/09/22 18:13:28 andreas_kupries Exp $
*/
#ifndef _TCLINT
@@ -1260,6 +1260,15 @@ typedef struct ResolverScheme {
typedef struct LimitHandler LimitHandler;
/*
+ * TIP #268.
+ * Values for the selection mode, i.e the package require preferences.
+ */
+
+enum PkgPreferOptions {
+ PKG_PREFER_LATEST, PKG_PREFER_STABLE
+};
+
+/*
*----------------------------------------------------------------
* This structure defines an interpreter, which is a collection of commands
* plus other state information related to interpreting commands, such as
@@ -1376,6 +1385,15 @@ typedef struct Interp {
* NULL. */
/*
+ * TIP #268.
+ * The currently active selection mode,
+ * i.e the package require preferences.
+ */
+
+ int packagePrefer; /* Current package selection mode.
+ */
+
+ /*
* Miscellaneous information:
*/
diff --git a/generic/tclPkg.c b/generic/tclPkg.c
index 9a990a2..0ff2b7c 100644
--- a/generic/tclPkg.c
+++ b/generic/tclPkg.c
@@ -5,11 +5,16 @@
* "package" command and a few C APIs.
*
* Copyright (c) 1996 Sun Microsystems, Inc.
+ * Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net>
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclPkg.c,v 1.15 2006/08/30 17:59:03 hobbs Exp $
+ * RCS: @(#) $Id: tclPkg.c,v 1.16 2006/09/22 18:13:28 andreas_kupries Exp $
+ *
+ * TIP #268.
+ * Heavily rewritten to handle the extend version numbers, and extended
+ * package requirements.
*/
#include "tclInt.h"
@@ -50,10 +55,25 @@ typedef struct Package {
* Prototypes for functions defined in this file:
*/
-static int CheckVersion(Tcl_Interp *interp, CONST char *string);
-static int ComparePkgVersions(CONST char *v1, CONST char *v2,
- int *satPtr);
+static int CheckVersionAndConvert(Tcl_Interp *interp, CONST char *string,
+ char** internal, int* stable);
+
+static int CompareVersions(CONST char *v1i, CONST char *v2i,
+ int *isMajorPtr);
+static int CheckRequirement(Tcl_Interp *interp, CONST char *string);
+static int CheckAllRequirements(Tcl_Interp* interp,
+ int reqc, Tcl_Obj *CONST reqv[]);
+static int RequirementSatisfied(CONST char *havei, CONST char *req);
+static int AllRequirementsSatisfied(CONST char *havei,
+ int reqc, Tcl_Obj *CONST reqv[]);
+static void AddRequirementsToResult(Tcl_Interp* interp,
+ int reqc, Tcl_Obj *CONST reqv[]);
+static void AddRequirementsToDString(Tcl_DString* dstring,
+ int reqc, Tcl_Obj *CONST reqv[]);
static Package * FindPackage(Tcl_Interp *interp, CONST char *name);
+static Tcl_Obj* ExactRequirement(CONST char* version);
+static void VersionCleanupProc(ClientData clientData,
+ Tcl_Interp *interp);
/*
*----------------------------------------------------------------------
@@ -96,6 +116,9 @@ Tcl_PkgProvideEx(
* for C callback function table) */
{
Package *pkgPtr;
+ char* pvi;
+ char* vi;
+ int res;
pkgPtr = FindPackage(interp, name);
if (pkgPtr->version == NULL) {
@@ -104,7 +127,19 @@ Tcl_PkgProvideEx(
pkgPtr->clientData = clientData;
return TCL_OK;
}
- if (ComparePkgVersions(pkgPtr->version, version, NULL) == 0) {
+
+ if (CheckVersionAndConvert (interp, pkgPtr->version, &pvi, NULL) != TCL_OK) {
+ return TCL_ERROR;
+ } else if (CheckVersionAndConvert (interp, version, &vi, NULL) != TCL_OK) {
+ Tcl_Free (pvi);
+ return TCL_ERROR;
+ }
+
+ res = CompareVersions(pvi, vi, NULL);
+ Tcl_Free (pvi);
+ Tcl_Free (vi);
+
+ if (res == 0) {
if (clientData != NULL) {
pkgPtr->clientData = clientData;
}
@@ -118,7 +153,7 @@ Tcl_PkgProvideEx(
/*
*----------------------------------------------------------------------
*
- * Tcl_PkgRequire / Tcl_PkgRequireEx --
+ * Tcl_PkgRequire / Tcl_PkgRequireEx / Tcl_PkgRequireProc --
*
* This function is called by code that depends on a particular version
* of a particular package. If the package is not already provided in the
@@ -171,11 +206,8 @@ Tcl_PkgRequireEx(
* is not returned. This is unchanged if this
* call fails for any reason. */
{
- Package *pkgPtr;
- PkgAvail *availPtr, *bestPtr;
- char *script;
- int code, satisfies, result, pass;
- Tcl_DString command;
+ Tcl_Obj *ov;
+ int res;
/*
* If an attempt is being made to load this into a standalone executable
@@ -248,6 +280,69 @@ Tcl_PkgRequireEx(
return NULL;
}
+ /* Translate between old and new API, and defer to the new function. */
+
+ if (exact) {
+ ov = ExactRequirement (version);
+ } else {
+ ov = Tcl_NewStringObj (version,-1);
+ }
+
+ Tcl_IncrRefCount (ov);
+ res = Tcl_PkgRequireProc(interp, name, 1, &ov, clientDataPtr);
+ Tcl_DecrRefCount (ov);
+
+ if (res != TCL_OK) {
+ return NULL;
+ }
+
+ /* This function returns the version string explictly, and leaves the
+ * interpreter result empty. However "Tcl_PkgRequireProc" above returned
+ * the version through the interpreter result. Simply resetting the result
+ * now potentially deletes the string (obj), and the pointer to its string
+ * rep we have, as our result, may be dangling due to this. Our solution
+ * is to remember the object in interp associated data, with a proper
+ * reference count, and then reset the result. Now pointers will not
+ * dangle. It will be a leak however if nothing is done. So the next time
+ * we come through here we delete the object remembered by this call, as
+ * we can then be sure that there is no pointer to its string around
+ * anymore. Beyond that we have a deletion function which cleans up the last
+ * remembered object which was not cleaned up directly, here.
+ */
+
+ ov = (Tcl_Obj*) Tcl_GetAssocData (interp, "tcl/Tcl_PkgRequireEx", NULL);
+ if (ov != NULL) {
+ Tcl_DecrRefCount (ov);
+ }
+
+ ov = Tcl_GetObjResult (interp);
+ Tcl_IncrRefCount (ov);
+ Tcl_SetAssocData(interp, "tcl/Tcl_PkgRequireEx", VersionCleanupProc,
+ (ClientData) ov);
+ Tcl_ResetResult (interp);
+
+ return Tcl_GetString (ov);
+}
+
+int
+Tcl_PkgRequireProc(
+ Tcl_Interp *interp, /* Interpreter in which package is now
+ * available. */
+ CONST char *name, /* Name of desired package. */
+ int reqc, /* Requirements constraining the desired version. */
+ Tcl_Obj *CONST reqv[], /* 0 means to use the latest version available. */
+ ClientData *clientDataPtr)
+{
+ Interp *iPtr = (Interp *) interp;
+ Package *pkgPtr;
+ PkgAvail *availPtr, *bestPtr, *bestStablePtr;
+ char *availVersion, *bestVersion; /* Internal rep. of versions */
+ int availStable;
+ char *script;
+ int code, satisfies, pass;
+ Tcl_DString command;
+ char* pkgVersionI;
+
/*
* It can take up to three passes to find the package: one pass to run the
* "package unknown" script, one to run the "package ifneeded" script for
@@ -270,36 +365,85 @@ Tcl_PkgRequireEx(
Tcl_AppendResult(interp, "circular package dependency: ",
"attempt to provide ", name, " ",
(char *)(pkgPtr->clientData), " requires ", name, NULL);
- if (version != NULL) {
- Tcl_AppendResult(interp, " ", version, NULL);
- }
- return NULL;
+ AddRequirementsToResult (interp, reqc, reqv);
+ return TCL_ERROR;
}
/*
* The package isn't yet present. Search the list of available
* versions and invoke the script for the best available version.
+ * We are actually locating the best, and the best stable version.
+ * One of them is then chosen based on the selection mode.
*/
- bestPtr = NULL;
- for (availPtr = pkgPtr->availPtr; availPtr != NULL;
- availPtr = availPtr->nextPtr) {
- if ((bestPtr != NULL) && (ComparePkgVersions(availPtr->version,
- bestPtr->version, NULL) <= 0)) {
+ bestPtr = NULL;
+ bestStablePtr = NULL;
+ bestVersion = NULL;
+
+ for (availPtr = pkgPtr->availPtr;
+ availPtr != NULL;
+ availPtr = availPtr->nextPtr) {
+ if (CheckVersionAndConvert (interp, availPtr->version,
+ &availVersion, &availStable) != TCL_OK) {
+ /* The provided version number is has invalid syntax. This
+ * should not happen. This should have been caught by the
+ * 'package ifneeded' registering the package.
+ */
+
continue;
}
- if (version != NULL) {
- result = ComparePkgVersions(availPtr->version, version,
- &satisfies);
- if ((result != 0) && exact) {
+
+ if (bestPtr != NULL) {
+ int res = CompareVersions (availVersion, bestVersion, NULL);
+ /* Note: Use internal reps! */
+ if (res <= 0) {
+ /* The version of the package sought is not as good as the
+ * currently selected version. Ignore it. */
+ Tcl_Free (availVersion);
+ availVersion = NULL;
continue;
}
+ }
+
+ /* We have found a version which is better than our max. */
+
+ if (reqc > 0) {
+ /* Check satisfaction of requirements */
+ satisfies = AllRequirementsSatisfied (availVersion, reqc, reqv);
if (!satisfies) {
+ Tcl_Free (availVersion);
+ availVersion = NULL;
continue;
}
}
+
bestPtr = availPtr;
+
+ if (bestVersion != NULL) Tcl_Free (bestVersion);
+ bestVersion = availVersion;
+
+ /* If this new best version is stable then it also has to be
+ * better than the max stable version found so far.
+ */
+
+ if (availStable) {
+ bestStablePtr = availPtr;
+ }
+ }
+
+ if (bestVersion != NULL) {
+ Tcl_Free (bestVersion);
+ }
+
+ /* Now choose a version among the two best. For 'latest' we simply
+ * take (actually keep) the best. For 'stable' we take the best
+ * stable, if there is any, or the best if there is nothing stable.
+ */
+
+ if ((iPtr->packagePrefer == PKG_PREFER_STABLE) && (bestStablePtr != NULL)) {
+ bestPtr = bestStablePtr;
}
+
if (bestPtr != NULL) {
/*
* We found an ifneeded script for the package. Be careful while
@@ -309,7 +453,7 @@ Tcl_PkgRequireEx(
*/
CONST char *versionToProvide = bestPtr->version;
script = bestPtr->script;
-
+
pkgPtr->clientData = (ClientData) versionToProvide;
Tcl_Preserve((ClientData) script);
Tcl_Preserve((ClientData) versionToProvide);
@@ -325,13 +469,29 @@ Tcl_PkgRequireEx(
name, " ", versionToProvide,
" failed: no version of package ", name,
" provided", NULL);
- } else if (0 != ComparePkgVersions(
- pkgPtr->version, versionToProvide, NULL)) {
- code = TCL_ERROR;
- Tcl_AppendResult(interp, "attempt to provide package ",
- name, " ", versionToProvide, " failed: package ",
- name, " ", pkgPtr->version, " provided instead",
- NULL);
+ } else {
+ char* pvi;
+ char* vi;
+ int res;
+
+ if (CheckVersionAndConvert (interp, pkgPtr->version, &pvi, NULL) != TCL_OK) {
+ code = TCL_ERROR;
+ } else if (CheckVersionAndConvert (interp, versionToProvide, &vi, NULL) != TCL_OK) {
+ Tcl_Free (pvi);
+ code = TCL_ERROR;
+ } else {
+ res = CompareVersions(pvi, vi, NULL);
+ Tcl_Free (pvi);
+ Tcl_Free (vi);
+
+ if (res != 0) {
+ code = TCL_ERROR;
+ Tcl_AppendResult(interp, "attempt to provide package ",
+ name, " ", versionToProvide, " failed: package ",
+ name, " ", pkgPtr->version, " provided instead",
+ NULL);
+ }
+ }
}
} else if (code != TCL_ERROR) {
Tcl_Obj *codePtr = Tcl_NewIntObj(code);
@@ -367,13 +527,14 @@ Tcl_PkgRequireEx(
pkgPtr->version = NULL;
}
pkgPtr->clientData = NULL;
- return NULL;
+ return TCL_ERROR;
}
+
break;
}
/*
- * Package not in the database. If there is a "package unknown"
+ * The package is not in the database. If there is a "package unknown"
* command, invoke it (but only on the first pass; after that, we
* should not get here in the first place).
*/
@@ -381,17 +542,14 @@ Tcl_PkgRequireEx(
if (pass > 1) {
break;
}
+
script = ((Interp *) interp)->packageUnknown;
if (script != NULL) {
Tcl_DStringInit(&command);
Tcl_DStringAppend(&command, script, -1);
Tcl_DStringAppendElement(&command, name);
- Tcl_DStringAppend(&command, " ", 1);
- Tcl_DStringAppend(&command, (version != NULL) ? version : "{}",
- -1);
- if (exact) {
- Tcl_DStringAppend(&command, " -exact", 7);
- }
+ AddRequirementsToDString(&command, reqc, reqv);
+
code = Tcl_EvalEx(interp, Tcl_DStringValue(&command),
Tcl_DStringLength(&command), TCL_EVAL_GLOBAL);
Tcl_DStringFree(&command);
@@ -406,7 +564,7 @@ Tcl_PkgRequireEx(
}
if (code == TCL_ERROR) {
Tcl_AddErrorInfo(interp, "\n (\"package unknown\" script)");
- return NULL;
+ return TCL_ERROR;
}
Tcl_ResetResult(interp);
}
@@ -414,38 +572,41 @@ Tcl_PkgRequireEx(
if (pkgPtr->version == NULL) {
Tcl_AppendResult(interp, "can't find package ", name, NULL);
- if (version != NULL) {
- Tcl_AppendResult(interp, " ", version, NULL);
- }
- return NULL;
+ AddRequirementsToResult(interp, reqc, reqv);
+ return TCL_ERROR;
}
/*
* At this point we know that the package is present. Make sure that the
- * provided version meets the current requirement.
+ * provided version meets the current requirements.
*/
- if (version == NULL) {
- if (clientDataPtr) {
- *clientDataPtr = pkgPtr->clientData;
- }
- return pkgPtr->version;
+ if (reqc == 0) {
+ satisfies = 1;
+ } else {
+ CheckVersionAndConvert (interp, pkgPtr->version, &pkgVersionI, NULL);
+ satisfies = AllRequirementsSatisfied (pkgVersionI, reqc, reqv);
+
+ Tcl_Free (pkgVersionI);
}
- result = ComparePkgVersions(pkgPtr->version, version, &satisfies);
- if ((satisfies && !exact) || (result == 0)) {
+
+ if (satisfies) {
if (clientDataPtr) {
*clientDataPtr = pkgPtr->clientData;
}
- return pkgPtr->version;
+ Tcl_SetObjResult (interp, Tcl_NewStringObj (pkgPtr->version, -1));
+ return TCL_OK;
}
+
Tcl_AppendResult(interp, "version conflict for package \"",
- name, "\": have ", pkgPtr->version, ", need ", version, NULL);
- return NULL;
+ name, "\": have ", pkgPtr->version, ", need", NULL);
+ AddRequirementsToResult (interp, reqc, reqv);
+ return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
- *q
+ *
* Tcl_PkgPresent / Tcl_PkgPresentEx --
*
* Checks to see whether the specified package is present. If it is not
@@ -502,6 +663,10 @@ Tcl_PkgPresentEx(
if (hPtr) {
pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
if (pkgPtr->version != NULL) {
+ char* pvi;
+ char* vi;
+ int thisIsMajor;
+
/*
* At this point we know that the package is present. Make sure
* that the provided version meets the current requirement.
@@ -514,7 +679,20 @@ Tcl_PkgPresentEx(
return pkgPtr->version;
}
- result = ComparePkgVersions(pkgPtr->version, version, &satisfies);
+
+ if (CheckVersionAndConvert (interp, pkgPtr->version, &pvi, NULL) != TCL_OK) {
+ return NULL;
+ } else if (CheckVersionAndConvert (interp, version, &vi, NULL) != TCL_OK) {
+ Tcl_Free (pvi);
+ return NULL;
+ }
+
+ result = CompareVersions(pvi, vi, &thisIsMajor);
+ Tcl_Free (pvi);
+ Tcl_Free (vi);
+
+ satisfies = (result == 0) || ((result == 1) && !thisIsMajor);
+
if ((satisfies && !exact) || (result == 0)) {
if (clientDataPtr) {
*clientDataPtr = pkgPtr->clientData;
@@ -563,13 +741,14 @@ Tcl_PackageObjCmd(
Tcl_Obj *CONST objv[]) /* Argument objects. */
{
static CONST char *pkgOptions[] = {
- "forget", "ifneeded", "names", "present", "provide", "require",
- "unknown", "vcompare", "versions", "vsatisfies", NULL
+ "forget", "ifneeded", "names", "prefer", "present",
+ "provide", "require", "unknown", "vcompare", "versions",
+ "vsatisfies", NULL
};
enum pkgOptions {
- PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, PKG_PRESENT,
- PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE,
- PKG_VERSIONS, PKG_VSATISFIES
+ PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, PKG_PREFER, PKG_PRESENT,
+ PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE, PKG_VERSIONS,
+ PKG_VSATISFIES
};
Interp *iPtr = (Interp *) interp;
int optionIndex, exact, i, satisfies;
@@ -580,6 +759,8 @@ Tcl_PackageObjCmd(
Tcl_HashTable *tablePtr;
CONST char *version;
char *argv2, *argv3, *argv4;
+ char* iva = NULL;
+ char* ivb = NULL;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
@@ -618,19 +799,23 @@ Tcl_PackageObjCmd(
}
case PKG_IFNEEDED: {
int length;
+ char* argv3i;
+ char* avi;
+ int res;
if ((objc != 4) && (objc != 5)) {
Tcl_WrongNumArgs(interp, 2, objv, "package version ?script?");
return TCL_ERROR;
}
argv3 = Tcl_GetString(objv[3]);
- if (CheckVersion(interp, argv3) != TCL_OK) {
+ if (CheckVersionAndConvert(interp, argv3, &argv3i, NULL) != TCL_OK) {
return TCL_ERROR;
}
argv2 = Tcl_GetString(objv[2]);
if (objc == 4) {
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
if (hPtr == NULL) {
+ Tcl_Free (argv3i);
return TCL_OK;
}
pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
@@ -638,10 +823,22 @@ Tcl_PackageObjCmd(
pkgPtr = FindPackage(interp, argv2);
}
argv3 = Tcl_GetStringFromObj(objv[3], &length);
- for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL;
- prevPtr = availPtr, availPtr = availPtr->nextPtr) {
- if (ComparePkgVersions(availPtr->version, argv3, NULL) == 0){
+
+ for (availPtr = pkgPtr->availPtr, prevPtr = NULL;
+ availPtr != NULL;
+ prevPtr = availPtr, availPtr = availPtr->nextPtr) {
+
+ if (CheckVersionAndConvert (interp, availPtr->version, &avi, NULL) != TCL_OK) {
+ Tcl_Free (argv3i);
+ return TCL_ERROR;
+ }
+
+ res = CompareVersions(avi, argv3i, NULL);
+ Tcl_Free (avi);
+
+ if (res == 0){
if (objc == 4) {
+ Tcl_Free (argv3i);
Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE);
return TCL_OK;
}
@@ -649,6 +846,8 @@ Tcl_PackageObjCmd(
break;
}
}
+ Tcl_Free (argv3i);
+
if (objc == 4) {
return TCL_OK;
}
@@ -656,6 +855,7 @@ Tcl_PackageObjCmd(
availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail));
availPtr->version = ckalloc((unsigned) (length + 1));
strcpy(availPtr->version, argv3);
+
if (prevPtr == NULL) {
availPtr->nextPtr = pkgPtr->availPtr;
pkgPtr->availPtr = availPtr;
@@ -698,7 +898,7 @@ Tcl_PackageObjCmd(
version = NULL;
if (objc == (4 + exact)) {
version = Tcl_GetString(objv[3 + exact]);
- if (CheckVersion(interp, version) != TCL_OK) {
+ if (CheckVersionAndConvert(interp, version, NULL, NULL) != TCL_OK) {
return TCL_ERROR;
}
} else if ((objc != 3) || exact) {
@@ -732,41 +932,50 @@ Tcl_PackageObjCmd(
return TCL_OK;
}
argv3 = Tcl_GetString(objv[3]);
- if (CheckVersion(interp, argv3) != TCL_OK) {
+ if (CheckVersionAndConvert(interp, argv3, NULL, NULL) != TCL_OK) {
return TCL_ERROR;
}
return Tcl_PkgProvide(interp, argv2, argv3);
case PKG_REQUIRE:
if (objc < 3) {
requireSyntax:
- Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?");
+ Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?requirement...?");
return TCL_ERROR;
}
+
+ version = NULL;
+
argv2 = Tcl_GetString(objv[2]);
if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) {
- exact = 1;
- } else {
- exact = 0;
- }
- version = NULL;
- if (objc == (4 + exact)) {
- version = Tcl_GetString(objv[3 + exact]);
- if (CheckVersion(interp, version) != TCL_OK) {
+ Tcl_Obj* ov;
+ int res;
+
+ if (objc != 5) {
+ goto requireSyntax;
+ }
+
+ version = Tcl_GetString(objv[4]);
+ if (CheckVersionAndConvert(interp, version, NULL, NULL) != TCL_OK) {
return TCL_ERROR;
}
- } else if ((objc != 3) || exact) {
- goto requireSyntax;
- }
- if (exact) {
- argv3 = Tcl_GetString(objv[3]);
- version = Tcl_PkgRequire(interp, argv3, version, exact);
+
+ /* Create a new-style requirement for the exact version. */
+
+ ov = ExactRequirement (version);
+ version = NULL;
+ argv3 = Tcl_GetString(objv[3]);
+
+ Tcl_IncrRefCount (ov);
+ res = Tcl_PkgRequireProc(interp, argv3, 1, &ov, NULL);
+ Tcl_DecrRefCount (ov);
+ return res;
} else {
- version = Tcl_PkgRequire(interp, argv2, version, exact);
- }
- if (version == NULL) {
- return TCL_ERROR;
+ if (CheckAllRequirements (interp, objc-3, objv+3) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ return Tcl_PkgRequireProc(interp, argv2, objc-3, objv+3, NULL);
}
- Tcl_SetObjResult(interp, Tcl_NewStringObj(version, -1));
break;
case PKG_UNKNOWN: {
int length;
@@ -792,6 +1001,34 @@ Tcl_PackageObjCmd(
}
break;
}
+ case PKG_PREFER: {
+ /* See tclInt.h for the enum, just before Interp */
+ static CONST char *pkgPreferOptions[] = {
+ "latest", "stable", NULL
+ };
+
+ if (objc > 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "?latest|stable?");
+ return TCL_ERROR;
+ }
+
+ if (objc == 3) {
+ /* Set value. */
+
+ int new;
+ if (Tcl_GetIndexFromObj(interp, objv[2], pkgPreferOptions, "preference", 0,
+ &new) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ if (new < iPtr->packagePrefer) {
+ iPtr->packagePrefer = new;
+ }
+ }
+ /* Always return current value. */
+ Tcl_SetObjResult(interp, Tcl_NewStringObj (pkgPreferOptions [iPtr->packagePrefer], -1));
+ break;
+ }
case PKG_VCOMPARE:
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "version1 version2");
@@ -799,12 +1036,17 @@ Tcl_PackageObjCmd(
}
argv3 = Tcl_GetString(objv[3]);
argv2 = Tcl_GetString(objv[2]);
- if ((CheckVersion(interp, argv2) != TCL_OK)
- || (CheckVersion(interp, argv3) != TCL_OK)) {
+ if ((CheckVersionAndConvert (interp, argv2, &iva, NULL) != TCL_OK) ||
+ (CheckVersionAndConvert (interp, argv3, &ivb, NULL) != TCL_OK)) {
+ if (iva != NULL) { Tcl_Free (iva); }
+ /* ivb cannot be set in this branch */
return TCL_ERROR;
}
- Tcl_SetObjResult(interp,
- Tcl_NewIntObj(ComparePkgVersions(argv2, argv3, NULL)));
+
+ /* Comparison is done on the internal representation */
+ Tcl_SetObjResult(interp,Tcl_NewIntObj(CompareVersions(iva, ivb, NULL)));
+ Tcl_Free (iva);
+ Tcl_Free (ivb);
break;
case PKG_VERSIONS:
if (objc != 3) {
@@ -821,20 +1063,28 @@ Tcl_PackageObjCmd(
}
}
break;
- case PKG_VSATISFIES:
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 2, objv, "version1 version2");
+ case PKG_VSATISFIES: {
+ char* argv2i = NULL;
+
+ if (objc < 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "version requirement requirement...");
return TCL_ERROR;
}
- argv3 = Tcl_GetString(objv[3]);
+
argv2 = Tcl_GetString(objv[2]);
- if ((CheckVersion(interp, argv2) != TCL_OK)
- || (CheckVersion(interp, argv3) != TCL_OK)) {
+ if ((CheckVersionAndConvert(interp, argv2, &argv2i, NULL) != TCL_OK)) {
+ return TCL_ERROR;
+ } else if (CheckAllRequirements (interp, objc-3, objv+3) != TCL_OK) {
+ Tcl_Free (argv2i);
return TCL_ERROR;
}
- ComparePkgVersions(argv2, argv3, &satisfies);
+
+ satisfies = AllRequirementsSatisfied (argv2i, objc-3, objv+3);
+ Tcl_Free (argv2i);
+
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(satisfies));
break;
+ }
default:
Tcl_Panic("Tcl_PackageObjCmd: bad option index to pkgOptions");
}
@@ -932,9 +1182,11 @@ TclFreePackageInfo(
/*
*----------------------------------------------------------------------
*
- * CheckVersion --
+ * CheckVersionAndConvert --
*
- * This function checks to see whether a version number has valid syntax.
+ * This function checks to see whether a version number has valid
+ * syntax. It also generates a semi-internal representation (string
+ * rep of a list of numbers).
*
* Results:
* If string is a properly formed version number the TCL_OK is returned.
@@ -948,30 +1200,82 @@ TclFreePackageInfo(
*/
static int
-CheckVersion(
- Tcl_Interp *interp, /* Used for error reporting. */
- CONST char *string) /* Supposedly a version number, which is
- * groups of decimal digits separated by
- * dots. */
+CheckVersionAndConvert(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ CONST char *string, /* Supposedly a version number, which is
+ * groups of decimal digits separated by
+ * dots. */
+ char** internal, /* Internal normalized representation */
+ int* stable) /* Flag: Version is (un)stable. */
{
CONST char *p = string;
char prevChar;
+ int hasunstable = 0;
+ /* 4* assuming that each char is a separator (a,b become ' -x ').
+ * 4+ to have spce for an additional -2 at the end
+ */
+ char* ibuf = Tcl_Alloc (4+4*strlen(string));
+ char* ip = ibuf;
+
+ /* Basic rules
+ * (1) First character has to be a digit.
+ * (2) All other characters have to be a digit or '.'
+ * (3) Two '.'s may not follow each other.
+
+ * TIP 268, Modified rules
+ * (1) s.a.
+ * (2) All other characters have to be a digit, 'a', 'b', or '.'
+ * (3) s.a.
+ * (4) Only one of 'a' or 'b' may occur.
+ * (5) Neither 'a', nor 'b' may occur before or after a '.'
+ */
if (!isdigit(UCHAR(*p))) { /* INTL: digit */
goto error;
}
+
+ *ip++ = *p;
+
for (prevChar = *p, p++; *p != 0; p++) {
- if (!isdigit(UCHAR(*p)) &&
- ((*p != '.') || (prevChar == '.'))) { /* INTL: digit */
+ if (
+ (!isdigit(UCHAR(*p))) &&
+ (((*p != '.') && (*p != 'a') && (*p != 'b')) ||
+ ((hasunstable && ((*p == 'a') || (*p == 'b'))) ||
+ (((prevChar == 'a') || (prevChar == 'b') || (prevChar == '.')) && (*p == '.')) ||
+ (((*p == 'a') || (*p == 'b') || (*p == '.')) && (prevChar == '.'))))
+ ) {
+ /* INTL: digit */
goto error;
}
+
+ if ((*p == 'a') || (*p == 'b')) { hasunstable = 1 ; }
+
+ /* Translation to the internal rep. Regular version chars are copied
+ * as is. The separators are translated to numerics. The new separator
+ * for all parts is space. */
+
+ if (*p == '.') { *ip++ = ' '; *ip++ = '0'; *ip++ = ' '; }
+ else if (*p == 'a') { *ip++ = ' '; *ip++ = '-'; *ip++ = '2'; *ip++ = ' '; }
+ else if (*p == 'b') { *ip++ = ' '; *ip++ = '-'; *ip++ = '1'; *ip++ = ' '; }
+ else { *ip++ = *p; }
+
prevChar = *p;
}
- if (prevChar != '.') {
+ if ((prevChar != '.') && (prevChar != 'a') && (prevChar != 'b')) {
+ *ip = '\0';
+ if (internal != NULL) {
+ *internal = ibuf;
+ } else {
+ Tcl_Free (ibuf);
+ }
+ if (stable != NULL) {
+ *stable = !hasunstable;
+ }
return TCL_OK;
}
error:
+ Tcl_Free (ibuf);
Tcl_AppendResult(interp, "expected version number but got \"", string,
"\"", NULL);
return TCL_ERROR;
@@ -980,9 +1284,9 @@ CheckVersion(
/*
*----------------------------------------------------------------------
*
- * ComparePkgVersions --
+ * CompareVersions --
*
- * This function compares two version numbers.
+ * This function compares two version numbers (in internal rep).
*
* Results:
* The return value is -1 if v1 is less than v2, 0 if the two version
@@ -997,22 +1301,30 @@ CheckVersion(
*/
static int
-ComparePkgVersions(
- CONST char *v1,
- CONST char *v2, /* Versions strings, of form 2.1.3 (any number
- * of version numbers). */
- int *satPtr) /* If non-null, the word pointed to is filled
- * in with a 0/1 value. 1 means v1 "satisfies"
- * v2: v1 is greater than or equal to v2 and
- * both version numbers have the same major
- * number. */
+CompareVersions(
+ CONST char *v1, /* Versions strings, of form 2.1.3 (any number */
+ CONST char *v2, /* of version numbers). */
+ int *isMajorPtr) /* If non-null, the word pointed to is filled
+ * in with a 0/1 value. 1 means that the difference
+ * occured in the first element. */
{
int thisIsMajor, n1, n2;
+ int res, flip;
/*
* Each iteration of the following loop processes one number from each
- * string, terminated by a ".". If those numbers don't match then the
+ * string, terminated by a " " (space). If those numbers don't match then the
* comparison is over; otherwise, we loop back for the next number.
+ *
+ * TIP 268.
+ * This is identical the function 'ComparePkgVersion', but using the new
+ * space separator as used by the internal rep of version numbers. The
+ * special separators 'a' and 'b' have already been dealt with in
+ * 'CheckVersionAndConvert', they were translated into numbers as
+ * well. This keeps the comparison sane. Otherwise we would have to
+ * compare numerics, the separators, and also deal with the special case
+ * of end-of-string compared to separators. The semi-list rep we get here
+ * is much easier to handle, as it is still regular.
*/
thisIsMajor = 1;
@@ -1022,14 +1334,20 @@ ComparePkgVersions(
*/
n1 = n2 = 0;
- while ((*v1 != 0) && (*v1 != '.')) {
+ flip = 0;
+ while ((*v1 != 0) && (*v1 != ' ')) {
+ if (*v1 == '-') {flip = 1 ; v1++ ; continue;}
n1 = 10*n1 + (*v1 - '0');
v1++;
}
- while ((*v2 != 0) && (*v2 != '.')) {
+ if (flip) n1 = -n1;
+ flip = 0;
+ while ((*v2 != 0) && (*v2 != ' ')) {
+ if (*v2 == '-') {flip = 1; v2++ ; continue;}
n2 = 10*n2 + (*v2 - '0');
v2++;
}
+ if (flip) n2 = -n2;
/*
* Compare and go on to the next version number if the current numbers
@@ -1049,15 +1367,424 @@ ComparePkgVersions(
}
thisIsMajor = 0;
}
- if (satPtr != NULL) {
- *satPtr = (n1 == n2) || ((n1 > n2) && !thisIsMajor);
- }
+
if (n1 > n2) {
- return 1;
+ res = 1;
} else if (n1 == n2) {
- return 0;
+ res = 0;
+ } else {
+ res = -1;
+ }
+
+ if (isMajorPtr != NULL) {
+ *isMajorPtr = thisIsMajor;
+ }
+
+ return res;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CheckAllRequirements --
+ *
+ * This function checks to see whether all requirements in a set
+ * have valid syntax.
+ *
+ * Results:
+ * TCL_OK is returned if all requirements are valid.
+ * Otherwise TCL_ERROR is returned and an error message
+ * is left in the interp's result.
+ *
+ * Side effects:
+ * May modify the interpreter result.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CheckAllRequirements(
+ Tcl_Interp* interp,
+ int reqc, /* Requirements to check. */
+ Tcl_Obj *CONST reqv[])
+{
+ int i;
+ for (i = 0; i < reqc; i++) {
+ if ((CheckRequirement(interp, Tcl_GetString(reqv[i])) != TCL_OK)) {
+ return TCL_ERROR;
+ }
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CheckRequirement --
+ *
+ * This function checks to see whether a requirement has valid syntax.
+ *
+ * Results:
+ * If string is a properly formed requirement then TCL_OK is returned.
+ * Otherwise TCL_ERROR is returned and an error message is left in the
+ * interp's result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CheckRequirement(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ CONST char *string) /* Supposedly a requirement. */
+{
+ /* Syntax of requirement = version
+ * = version-version
+ * = version-
+ */
+
+ char* dash = NULL;
+ char* buf;
+
+ dash = strchr (string, '-');
+ if (dash == NULL) {
+ /* no dash found, has to be a simple version */
+ return CheckVersionAndConvert (interp, string, NULL, NULL);
+ }
+ if (strchr (dash+1, '-') != NULL) {
+ /* More dashes found after the first. This is wrong. */
+ Tcl_AppendResult(interp, "expected versionMin-versionMax but got \"", string,
+ "\"", NULL);
+ return TCL_ERROR;
+ }
+
+ /* Exactly one dash is present. Copy the string, split at the location of
+ * dash and check that both parts are versions. Note that the max part can
+ * be empty.
+ */
+
+ buf = strdup (string);
+ dash = buf + (dash - string);
+ *dash = '\0'; /* buf now <=> min part */
+ dash ++; /* dash now <=> max part */
+
+ if ((CheckVersionAndConvert(interp, buf, NULL, NULL) != TCL_OK) ||
+ ((*dash != '\0') &&
+ (CheckVersionAndConvert(interp, dash, NULL, NULL) != TCL_OK))) {
+ free (buf);
+ return TCL_ERROR;
+ }
+
+ free (buf);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * AddRequirementsToResult --
+ *
+ * This function accumulates requirements in the interpreter result.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The interpreter result is extended.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+AddRequirementsToResult(
+ Tcl_Interp* interp,
+ int reqc, /* Requirements constraining the desired version. */
+ Tcl_Obj *CONST reqv[]) /* 0 means to use the latest version available. */
+{
+ if (reqc > 0) {
+ int i;
+ for (i = 0; i < reqc; i++) {
+ Tcl_AppendResult(interp, " ", TclGetString(reqv[i]), NULL);
+ }
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * AddRequirementsToDString --
+ *
+ * This function accumulates requirements in a DString.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The DString argument is extended.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+AddRequirementsToDString(
+ Tcl_DString* dstring,
+ int reqc, /* Requirements constraining the desired version. */
+ Tcl_Obj *CONST reqv[]) /* 0 means to use the latest version available. */
+{
+ if (reqc > 0) {
+ int i;
+ for (i = 0; i < reqc; i++) {
+ Tcl_DStringAppend(dstring, " ", 1);
+ Tcl_DStringAppend(dstring, TclGetString(reqv[i]), -1);
+ }
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * AllRequirementSatisfied --
+ *
+ * This function checks to see whether a version satisfies at
+ * least one of a set of requirements.
+ *
+ * Results:
+ * If the requirements are satisfied 1 is returned.
+ * Otherwise 0 is returned. The function assumes
+ * that all pieces have valid syntax. And is allowed
+ * to make that assumption.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+AllRequirementsSatisfied(
+ CONST char* availVersionI, /* Candidate version to check against the requirements */
+ int reqc, /* Requirements constraining the desired version. */
+ Tcl_Obj *CONST reqv[]) /* 0 means to use the latest version available. */
+{
+ int i, satisfies;
+
+ for (satisfies = i = 0; i < reqc; i++) {
+ satisfies = RequirementSatisfied(availVersionI, Tcl_GetString(reqv[i]));
+ if (satisfies) break;
+ }
+ return satisfies;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * RequirementSatisfied --
+ *
+ * This function checks to see whether a version satisfies a requirement.
+ *
+ * Results:
+ * If the requirement is satisfied 1 is returned.
+ * Otherwise 0 is returned. The function assumes
+ * that all pieces have valid syntax. And is allowed
+ * to make that assumption.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+RequirementSatisfied(
+ CONST char *havei, /* Version string, of candidate package we have */
+ CONST char *req) /* Requirement string the candidate has to satisfy */
+{
+ /* The have candidate is already in internal rep. */
+
+ int satisfied, res;
+ char* dash = NULL;
+ char* buf, *min, *max;
+
+ dash = strchr (req, '-');
+ if (dash == NULL) {
+ /* No dash found, is a simple version, fallback to regular check.
+ * The 'CheckVersionAndConvert' cannot fail. We pad the requirement with
+ * 'a0', i.e '-2' before doing the comparison to properly accept
+ * unstables as well.
+ */
+
+ char* reqi = NULL;
+ int thisIsMajor;
+
+ CheckVersionAndConvert (NULL, req, &reqi, NULL);
+ strcat (reqi, " -2");
+ res = CompareVersions(havei, reqi, &thisIsMajor);
+ satisfied = (res == 0) || ((res == 1) && !thisIsMajor);
+ Tcl_Free (reqi);
+ return satisfied;
+ }
+
+ /* Exactly one dash is present (Assumption of valid syntax). Copy the req,
+ * split at the location of dash and check that both parts are
+ * versions. Note that the max part can be empty.
+ */
+
+ buf = strdup (req);
+ dash = buf + (dash - req);
+ *dash = '\0'; /* buf now <=> min part */
+ dash ++; /* dash now <=> max part */
+
+ if (*dash == '\0') {
+ /* We have a min, but no max. For the comparison we generate the
+ * internal rep, padded with 'a0' i.e. '-2'.
+ */
+
+ /* No max part, unbound */
+
+ CheckVersionAndConvert (NULL, buf, &min, NULL);
+ strcat (min, " -2");
+ satisfied = (CompareVersions(havei, min, NULL) >= 0);
+ Tcl_Free (min);
+ free (buf);
+ return satisfied;
+ }
+
+ /* We have both min and max, and generate their internal reps.
+ * When identical we compare as is, otherwise we pad with 'a0'
+ * to ove the range a bit.
+ */
+
+ CheckVersionAndConvert (NULL, buf, &min, NULL);
+ CheckVersionAndConvert (NULL, dash, &max, NULL);
+
+ if (CompareVersions(min, max, NULL) == 0) {
+ satisfied = (CompareVersions(min, havei, NULL) == 0);
} else {
- return -1;
+ strcat (min, " -2");
+ strcat (max, " -2");
+ satisfied = ((CompareVersions(min, havei, NULL) <= 0) &&
+ (CompareVersions(havei, max, NULL) < 0));
+ }
+
+ Tcl_Free (min);
+ Tcl_Free (max);
+ free (buf);
+ return satisfied;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ExactRequirement --
+ *
+ * This function is the core for the translation of -exact requests.
+ * It translates the request of the version into a range of versions.
+ * The translation was chosen for backwards compatibility.
+ *
+ * Results:
+ * A Tcl_Obj containing the version range as string.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Tcl_Obj*
+ExactRequirement(version)
+ CONST char* version;
+{
+ /* A -exact request for a version X.y is translated into the range
+ * X.y-X.(y+1). For example -exact 8.4 means the range "8.4-8.5".
+ *
+ * This translation was chosen to prevent packages which currently use a
+ * 'package require -exact tclversion' from being affected by the core now
+ * registering itself as 8.4.x (patchlevel) instead of 8.4
+ * (version). Examples are tbcload, compiler, and ITcl.
+ *
+ * Translating -exact 8.4 to the range "8.4-8.4" instead would require us
+ * and everyone else to rebuild these packages to require -exact 8.4.14,
+ * or whatever the exact current patchlevel is. A backward compatibility
+ * issue with effects similar to the bugfix made in 8.5 now requiring
+ * ifneeded and provided versions to match. Instead we have chosen to
+ * interpret exactness to not be exactly equal, but to be exact only
+ * within the specified level, and allowing variation in the deeper
+ * level. More examples:
+ *
+ * -exact 8 => "8-9"
+ * -exact 8.4 => "8.4-8.5"
+ * -exact 8.4.14 => "8.4.14-8.4.15"
+ * -exact 8.0a2 => "8.0a2-8.0a3"
+ */
+
+ char* iv;
+ int lc, i;
+ CONST char** lv;
+ char buf [30];
+ Tcl_Obj* o = Tcl_NewStringObj (version,-1);
+ Tcl_AppendStringsToObj (o, "-", NULL);
+
+ /* Assuming valid syntax here */
+ CheckVersionAndConvert (NULL, version, &iv, NULL);
+
+ /* Split the list into components */
+ Tcl_SplitList (NULL, iv, &lc, &lv);
+
+ /* Iterate over the components and make them parts of the result. Except
+ * for the last, which is handled separately, to allow the
+ * incrementation.
+ */
+
+ for (i=0; i < (lc-1); i++) {
+ /* Regular component */
+ Tcl_AppendStringsToObj (o, lv[i], NULL);
+ /* Separator component */
+ i ++;
+ if (0 == strcmp ("-1", lv[i])) {
+ Tcl_AppendStringsToObj (o, "b", NULL);
+ } else if (0 == strcmp ("-2", lv[i])) {
+ Tcl_AppendStringsToObj (o, "a", NULL);
+ } else {
+ Tcl_AppendStringsToObj (o, ".", NULL);
+ }
+ }
+ /* Regular component, last */
+ sprintf (buf, "%d", atoi (lv [lc-1]) + 1);
+ Tcl_AppendStringsToObj (o, buf, NULL);
+
+ ckfree ((char*) lv);
+ return o;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * VersionCleanupProc --
+ *
+ * This function is called to delete the last remember package version
+ * string for an interpreter when the interpreter is deleted. It gets
+ * invoked via the Tcl AssocData mechanism.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Storage for the version object for interp get deleted.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+VersionCleanupProc (
+ ClientData clientData, /* Pointer to remembered version string object
+ * for interp. */
+ Tcl_Interp *interp) /* Interpreter that is being deleted. */
+{
+ Tcl_Obj* ov = (Tcl_Obj*) clientData;
+ if (ov != NULL) {
+ Tcl_DecrRefCount (ov);
}
}
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 9d52015..4a68100 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclStubInit.c,v 1.131 2006/06/21 03:10:39 dgp Exp $
+ * RCS: @(#) $Id: tclStubInit.c,v 1.132 2006/09/22 18:13:29 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -1070,6 +1070,7 @@ TclStubs tclStubs = {
Tcl_GetEncodingSearchPath, /* 570 */
Tcl_SetEncodingSearchPath, /* 571 */
Tcl_GetEncodingNameFromEnvironment, /* 572 */
+ Tcl_PkgRequireProc, /* 573 */
};
/* !END!: Do not edit above this line. */
diff --git a/generic/tclTest.c b/generic/tclTest.c
index d05e9f2..2e0f4ae 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -14,7 +14,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclTest.c,v 1.104 2006/06/21 20:44:59 das Exp $
+ * RCS: @(#) $Id: tclTest.c,v 1.105 2006/09/22 18:13:29 andreas_kupries Exp $
*/
#define TCL_TEST
@@ -560,7 +560,9 @@ Tcltest_Init(
"-appinitprocclosestderr", "-appinitprocsetrcfile", NULL
};
- if (Tcl_PkgProvide(interp, "Tcltest", TCL_VERSION) == TCL_ERROR) {
+ /* TIP #268: Full patchlevel instead of just major.minor */
+
+ if (Tcl_PkgProvide(interp, "Tcltest", TCL_PATCH_LEVEL) == TCL_ERROR) {
return TCL_ERROR;
}
diff --git a/generic/tclTomMathInterface.c b/generic/tclTomMathInterface.c
index 65eddcf..f726531 100644
--- a/generic/tclTomMathInterface.c
+++ b/generic/tclTomMathInterface.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclTomMathInterface.c,v 1.6 2005/12/13 22:43:18 kennykb Exp $
+ * RCS: @(#) $Id: tclTomMathInterface.c,v 1.7 2006/09/22 18:13:29 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -42,7 +42,9 @@ int
TclTommath_Init(
Tcl_Interp* interp /* Tcl interpreter */
) {
- if (Tcl_PkgProvideEx(interp, "tcl::tommath", TCL_VERSION,
+ /* TIP #268: Full patchlevel instead of just major.minor */
+
+ if (Tcl_PkgProvideEx(interp, "tcl::tommath", TCL_PATCH_LEVEL,
(ClientData)&tclTomMathStubs) != TCL_OK) {
return TCL_ERROR;
}