Attachment "tip-339-tcl85.patch" to
ticket [2316115fff]
added by
andreas_kupries
2008-11-27 05:59:02.
--- tcl85.orig/generic/tclBasic.c 2008-11-18 09:09:56.000000000 -0800
+++ tcl85/generic/tclBasic.c 2008-11-21 14:26:48.000000000 -0800
@@ -471,6 +471,9 @@
iPtr->appendUsed = 0;
Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS);
+#ifdef TCL_TIP339
+ Tcl_InitHashTable(&iPtr->packageTableLC, TCL_STRING_KEYS);
+#endif
iPtr->packageUnknown = NULL;
/* TIP #268 */
@@ -814,6 +817,11 @@
Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs);
+#ifdef TCL_TIP339
+ Tcl_SetVar2(interp, "tcl_platform", "tip,339", "1",
+ TCL_GLOBAL_ONLY);
+#endif
+
#ifdef Tcl_InitStubs
#undef Tcl_InitStubs
#endif
--- tcl85.orig/generic/tcl.decls 2008-11-18 09:13:20.000000000 -0800
+++ tcl85/generic/tcl.decls 2008-11-21 14:27:59.000000000 -0800
@@ -2099,6 +2099,22 @@
void Tcl_AppendPrintfToObj(Tcl_Obj *objPtr, CONST char *format, ...)
}
+# TIP#285: Script cancellation (580-581)
+# TIP#304: chan pipe (582)
+# TIP#322: NRE public API (583-588)
+# TIP#316: StatBuf acessors (589-601)
+# TIP#314: Parameterized ensembles (602-603)
+# TIP#265: Option parser (604)
+
+# TIP#339: Case-insensitive package names
+# The slot is present even if TCL_TIP339 is not activated.
+
+declare 605 generic {
+ int Tcl_PkgRequireProcEx(Tcl_Interp *interp, CONST char *name,
+ int objc, Tcl_Obj *CONST objv[], ClientData *clientDataPtr,
+ int flags)
+}
+
##############################################################################
# Define the platform specific public Tcl interface. These functions are
--- tcl85.orig/generic/tclDecls.h 2008-11-18 09:13:20.000000000 -0800
+++ tcl85/generic/tclDecls.h 2008-11-21 15:38:22.000000000 -0800
@@ -3501,6 +3501,39 @@
EXTERN void Tcl_AppendPrintfToObj (Tcl_Obj * objPtr,
CONST char * format, ...);
#endif
+/* Slot 580 is reserved */
+/* Slot 581 is reserved */
+/* Slot 582 is reserved */
+/* Slot 583 is reserved */
+/* Slot 584 is reserved */
+/* Slot 585 is reserved */
+/* Slot 586 is reserved */
+/* Slot 587 is reserved */
+/* Slot 588 is reserved */
+/* Slot 589 is reserved */
+/* Slot 590 is reserved */
+/* Slot 591 is reserved */
+/* Slot 592 is reserved */
+/* Slot 593 is reserved */
+/* Slot 594 is reserved */
+/* Slot 595 is reserved */
+/* Slot 596 is reserved */
+/* Slot 597 is reserved */
+/* Slot 598 is reserved */
+/* Slot 599 is reserved */
+/* Slot 600 is reserved */
+/* Slot 601 is reserved */
+/* Slot 602 is reserved */
+/* Slot 603 is reserved */
+/* Slot 604 is reserved */
+#ifndef Tcl_PkgRequireProcEx_TCL_DECLARED
+#define Tcl_PkgRequireProcEx_TCL_DECLARED
+/* 605 */
+EXTERN int Tcl_PkgRequireProcEx (Tcl_Interp * interp,
+ CONST char * name, int objc,
+ Tcl_Obj *CONST objv[],
+ ClientData * clientDataPtr, int flags);
+#endif
typedef struct TclStubHooks {
struct TclPlatStubs *tclPlatStubs;
@@ -4140,6 +4173,32 @@
int (*tcl_AppendFormatToObj) (Tcl_Interp * interp, Tcl_Obj * objPtr, CONST char * format, int objc, Tcl_Obj * CONST objv[]); /* 577 */
Tcl_Obj * (*tcl_ObjPrintf) (CONST char * format, ...); /* 578 */
void (*tcl_AppendPrintfToObj) (Tcl_Obj * objPtr, CONST char * format, ...); /* 579 */
+ void *reserved580;
+ void *reserved581;
+ void *reserved582;
+ void *reserved583;
+ void *reserved584;
+ void *reserved585;
+ void *reserved586;
+ void *reserved587;
+ void *reserved588;
+ void *reserved589;
+ void *reserved590;
+ void *reserved591;
+ void *reserved592;
+ void *reserved593;
+ void *reserved594;
+ void *reserved595;
+ void *reserved596;
+ void *reserved597;
+ void *reserved598;
+ void *reserved599;
+ void *reserved600;
+ void *reserved601;
+ void *reserved602;
+ void *reserved603;
+ void *reserved604;
+ int (*tcl_PkgRequireProcEx) (Tcl_Interp * interp, CONST char * name, int objc, Tcl_Obj *CONST objv[], ClientData * clientDataPtr, int flags); /* 605 */
} TclStubs;
#ifdef __cplusplus
@@ -6536,6 +6595,35 @@
#define Tcl_AppendPrintfToObj \
(tclStubsPtr->tcl_AppendPrintfToObj) /* 579 */
#endif
+/* Slot 580 is reserved */
+/* Slot 581 is reserved */
+/* Slot 582 is reserved */
+/* Slot 583 is reserved */
+/* Slot 584 is reserved */
+/* Slot 585 is reserved */
+/* Slot 586 is reserved */
+/* Slot 587 is reserved */
+/* Slot 588 is reserved */
+/* Slot 589 is reserved */
+/* Slot 590 is reserved */
+/* Slot 591 is reserved */
+/* Slot 592 is reserved */
+/* Slot 593 is reserved */
+/* Slot 594 is reserved */
+/* Slot 595 is reserved */
+/* Slot 596 is reserved */
+/* Slot 597 is reserved */
+/* Slot 598 is reserved */
+/* Slot 599 is reserved */
+/* Slot 600 is reserved */
+/* Slot 601 is reserved */
+/* Slot 602 is reserved */
+/* Slot 603 is reserved */
+/* Slot 604 is reserved */
+#ifndef Tcl_PkgRequireProcEx
+#define Tcl_PkgRequireProcEx \
+ (tclStubsPtr->tcl_PkgRequireProcEx) /* 605 */
+#endif
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
--- tcl85.orig/generic/tcl.h 2008-11-18 09:09:56.000000000 -0800
+++ tcl85/generic/tcl.h 2008-11-21 14:29:39.000000000 -0800
@@ -2150,6 +2150,13 @@
typedef unsigned short Tcl_UniChar;
#endif
+#ifdef TCL_TIP339
+ /* Flags for Tcl_Pkg{Present,Require} instead of the exact boolean.
+ */
+#define TCL_PKG_EXACT (1) /* Exact version required */
+#define TCL_PKG_STRICT (2) /* Use strict (case-sensitive) package name comparison */
+#endif
+
/*
* TIP #59: The following structure is used in calls 'Tcl_RegisterConfig' to
* provide the system with the embedded configuration data.
--- tcl85.orig/generic/tclInt.h 2008-11-18 09:13:20.000000000 -0800
+++ tcl85/generic/tclInt.h 2008-11-21 14:30:56.000000000 -0800
@@ -1912,7 +1912,16 @@
* TclpCheckStackSpace in the platform's
* directory. */
-
+#ifdef TCL_TIP339
+ Tcl_HashTable packageTableLC; /* Describes all of the packages
+ * loaded in or available to this
+ * interpreter. Keys are package
+ * names in lower case for
+ * non-strict searching, values are
+ * (Package *) pointers. Contains
+ * only the first name in the eq.class
+ */
+#endif
#ifdef TCL_COMPILE_STATS
/*
* Statistical information about the bytecode compiler and interpreter's
--- tcl85.orig/generic/tclPkg.c 2008-11-18 09:09:57.000000000 -0800
+++ tcl85/generic/tclPkg.c 2008-11-21 15:38:02.000000000 -0800
@@ -49,6 +49,18 @@
PkgAvail *availPtr; /* First in list of all available versions of
* this package. */
ClientData clientData; /* Client data. */
+
+#ifdef TCL_TIP339
+ Tcl_HashEntry *myHEPtr; /* Owning hash entry in packageTable */
+ Tcl_HashEntry *myHEPtrLC; /* Owning hash entry in packageTableLC, if any */
+ struct Package *firstEqPtr; /* First, last, and next element of the list of */
+ struct Package *lastEqPtr; /* equivalent packages, when comparing names */
+ struct Package *nextEqPtr; /* case-insensitively. First and next are
+ * always set. Next however only when the list
+ * contains more than one element. Last is set
+ * only for the first element, and only if the
+ * list contains more than one element. */
+#endif
} Package;
/*
@@ -70,10 +82,24 @@
Tcl_Obj *const reqv[]);
static void AddRequirementsToDString(Tcl_DString *dstring,
int reqc, Tcl_Obj *const reqv[]);
+#ifdef TCL_TIP339
+static Package * FindPackage(Tcl_Interp *interp, const char *name, int strict);
+static const char * PkgRequireCore(Tcl_Interp *interp, const char *name,
+ int reqc, Tcl_Obj *CONST reqv[],
+ ClientData *clientDataPtr, int strict);
+#else
static Package * FindPackage(Tcl_Interp *interp, const char *name);
static const char * PkgRequireCore(Tcl_Interp *interp, const char *name,
int reqc, Tcl_Obj *const reqv[],
ClientData *clientDataPtr);
+#endif
+
+#ifdef TCL_TIP339
+static Tcl_HashEntry * LookupPackage(Interp *iPtr, CONST char *name, int strict);
+#else
+/*static Tcl_HashEntry * LookupPackage(Interp *iPtr, CONST char *name); */
+#define LookupPackage(iPtr,name) (Tcl_FindHashEntry(&(iPtr)->packageTable, (name)))
+#endif
/*
* Helper macros.
@@ -131,13 +157,25 @@
char *pvi, *vi;
int res;
+#ifdef TCL_TIP339
+ pkgPtr = FindPackage(interp, name, TCL_PKG_STRICT);
+#else
pkgPtr = FindPackage(interp, name);
+#endif
if (pkgPtr->version == NULL) {
+ /* This package was not loaded yet and now is, remember the loaded
+ * version.
+ */
+
DupString(pkgPtr->version, version);
pkgPtr->clientData = clientData;
return TCL_OK;
}
+ /* A version of the package has been loaded already. Check that the now
+ * requested version matches what we have, throw an error otherwise.
+ */
+
if (CheckVersionAndConvert(interp, pkgPtr->version, &pvi,
NULL) != TCL_OK) {
return TCL_ERROR;
@@ -188,6 +226,25 @@
*----------------------------------------------------------------------
*/
+#ifndef TCL_TIP339
+/*
+ * Empty definition for Stubs when TIP 339 is not activated.
+ * Note: Combination of !268, !339 will likely not work
+ */
+int
+Tcl_PkgRequireProcEx(interp,name,reqc,reqv,clientDataPtr,flags)
+ 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;
+ int flags;
+{
+ return TCL_ERROR;
+}
+#endif
+
const char *
Tcl_PkgRequire(
Tcl_Interp *interp, /* Interpreter in which package is now
@@ -217,6 +274,11 @@
* is not returned. This is unchanged if this
* call fails for any reason. */
{
+ /*
+ * With TCL_TIP339 active 'exact' becomes a flags bitfield, compared to a
+ * plain boolean without.
+ */
+
Tcl_Obj *ov;
const char *result = NULL;
@@ -296,8 +358,26 @@
*/
if (version == NULL) {
+#ifdef TCL_TIP339
+ result = PkgRequireCore(interp, name, 0, NULL, clientDataPtr,
+ exact & TCL_PKG_STRICT);
+#else
result = PkgRequireCore(interp, name, 0, NULL, clientDataPtr);
+#endif
} else {
+#ifdef TCL_TIP339
+ if ((exact & TCL_PKG_EXACT) && TCL_OK
+ != CheckVersionAndConvert(interp, version, NULL, NULL)) {
+ return NULL;
+ }
+ ov = Tcl_NewStringObj(version, -1);
+ if (exact & TCL_PKG_EXACT) {
+ Tcl_AppendStringsToObj(ov, "-", version, NULL);
+ }
+ Tcl_IncrRefCount (ov);
+ result = PkgRequireCore(interp, name, 1, &ov, clientDataPtr,
+ exact & TCL_PKG_STRICT);
+#else
if (exact && TCL_OK
!= CheckVersionAndConvert(interp, version, NULL, NULL)) {
return NULL;
@@ -308,6 +388,7 @@
}
Tcl_IncrRefCount(ov);
result = PkgRequireCore(interp, name, 1, &ov, clientDataPtr);
+#endif
TclDecrRefCount(ov);
}
@@ -325,8 +406,28 @@
* available. */
ClientData *clientDataPtr)
{
+#ifdef TCL_TIP339
+ return Tcl_PkgRequireProcEx (interp, name, reqc, reqv, clientDataPtr, 0 /*!strict*/);
+}
+
+int
+Tcl_PkgRequireProcEx(
+ 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,
+ int flags)
+{
+ const char *result =
+ PkgRequireCore(interp, name, reqc, reqv, clientDataPtr, flags & TCL_PKG_STRICT);
+#else
const char *result =
PkgRequireCore(interp, name, reqc, reqv, clientDataPtr);
+#endif
if (result == NULL) {
return TCL_ERROR;
@@ -344,7 +445,11 @@
* version. */
Tcl_Obj *const reqv[], /* 0 means to use the latest version
* available. */
- ClientData *clientDataPtr)
+ ClientData *clientDataPtr
+#ifdef TCL_TIP339
+ , int flags /* TCL_PKG_STRICT package search or not ? */
+#endif
+)
{
Interp *iPtr = (Interp *) interp;
Package *pkgPtr;
@@ -363,7 +468,11 @@
*/
for (pass=1 ;; pass++) {
+#ifdef TCL_TIP339
+ pkgPtr = FindPackage(interp, name, flags & TCL_PKG_STRICT);
+#else
pkgPtr = FindPackage(interp, name);
+#endif
if (pkgPtr->version != NULL) {
break;
}
@@ -486,7 +595,11 @@
code = Tcl_EvalEx(interp, script, -1, TCL_EVAL_GLOBAL);
Tcl_Release((ClientData) script);
+#ifdef TCL_TIP339
+ pkgPtr = FindPackage(interp, name, flags & TCL_PKG_STRICT);
+#else
pkgPtr = FindPackage(interp, name);
+#endif
if (code == TCL_OK) {
Tcl_ResetResult(interp);
if (pkgPtr->version == NULL) {
@@ -686,7 +799,17 @@
Tcl_HashEntry *hPtr;
Package *pkgPtr;
- hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name);
+#ifdef TCL_TIP339
+ /*
+ * With TIP#339 code active 'exact' is a flags bit-field, and not a plain
+ * boolean. Tcl_PkgRequireEx changed in the same way, so nothing special
+ * needed there.
+ */
+
+ hPtr = LookupPackage (iPtr, name, exact & TCL_PKG_STRICT);
+#else
+ hPtr = LookupPackage (iPtr, name);
+#endif
if (hPtr) {
pkgPtr = Tcl_GetHashValue(hPtr);
if (pkgPtr->version != NULL) {
@@ -734,6 +857,35 @@
*----------------------------------------------------------------------
*/
+static void
+Forget (Package *pkgPtr)
+{
+ PkgAvail* availPtr;
+
+ if (pkgPtr->version != NULL) {
+ ckfree(pkgPtr->version);
+ }
+ while (pkgPtr->availPtr != NULL) {
+ availPtr = pkgPtr->availPtr;
+ pkgPtr->availPtr = availPtr->nextPtr;
+ Tcl_EventuallyFree((ClientData)availPtr->version, TCL_DYNAMIC);
+ Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
+ ckfree((char *) availPtr);
+ }
+ ckfree((char *) pkgPtr);
+}
+
+#ifdef TCL_TIP339
+static Package*
+GetPrevious (Package *pkgPtr, Package* findPtr)
+{
+ while (pkgPtr->nextEqPtr != findPtr) {
+ pkgPtr = pkgPtr->nextEqPtr;
+ }
+ return pkgPtr;
+}
+#endif
+
/* ARGSUSED */
int
Tcl_PackageObjCmd(
@@ -775,6 +927,100 @@
case PKG_FORGET: {
char *keyString;
+#ifdef TCL_TIP339
+ int start = 2;
+ int strict = 0;
+
+ if ((argv2[0] == '-') && (strcmp(argv2, "-strict") == 0)) {
+ start ++;
+ strict = 1;
+ }
+
+ for (i = start; i < objc; i++) {
+ keyString = Tcl_GetString(objv[i]);
+
+ hPtr = LookupPackage (iPtr, keyString, strict);
+
+ if (hPtr == NULL) {
+ continue;
+ }
+
+ pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
+
+ if (strict) {
+ /*
+ * Delete just this package. Remove it from its equivalence
+ * class as well. Depending on where it is (first, or middle)
+ * we may have to update the LC table.
+ */
+
+ if (pkgPtr->firstEqPtr == pkgPtr) {
+ /*
+ * The removed package is the first in its equivalence
+ * class.
+ */
+
+ if (pkgPtr->nextEqPtr) {
+ /*
+ * The class will not become empty however, therefore
+ * correct the first/last links, and the LC entry for
+ * the class, the first links and the latter to point
+ * to the new first of the class.
+ */
+
+ Package* runPtr = pkgPtr->nextEqPtr;
+
+ runPtr->lastEqPtr = pkgPtr->lastEqPtr;
+ Tcl_SetHashValue(pkgPtr->myHEPtrLC, runPtr);
+
+ while (runPtr) {
+ runPtr->firstEqPtr = pkgPtr->nextEqPtr;
+ runPtr = runPtr->nextEqPtr;
+ }
+ } else {
+ /*
+ * The class contained only this element, and is thus
+ * now gone, therefore we have to delete its LC entry.
+ */
+ Tcl_DeleteHashEntry(pkgPtr->myHEPtrLC);
+ }
+ } else {
+ /*
+ * The removed package is in the middle of its class. We
+ * have to cut its structure out of the class list, and
+ * correct the next/last pointers.
+ */
+ Package* firstPtr = pkgPtr->firstEqPtr;
+ Package* prevPtr = GetPrevious (firstPtr, pkgPtr);
+ prevPtr->nextEqPtr = pkgPtr->nextEqPtr;
+ if (firstPtr->lastEqPtr == pkgPtr) {
+ firstPtr->lastEqPtr = prevPtr->nextEqPtr;
+ }
+ }
+
+ Tcl_DeleteHashEntry(hPtr);
+ Forget (pkgPtr);
+
+ } else {
+ /*
+ * We did a non-strict search, this means we have to delete
+ * the whole equivalence class. That is much simpler than
+ * manipulating just parts of the class list.
+ */
+
+ Package* firstPtr = pkgPtr->firstEqPtr;
+ Package* nextPtr;
+
+ Tcl_DeleteHashEntry(firstPtr->myHEPtrLC);
+ while (firstPtr) {
+ Tcl_DeleteHashEntry(firstPtr->myHEPtr);
+ nextPtr = firstPtr->nextEqPtr;
+ Forget (firstPtr);
+ firstPtr = nextPtr;
+ }
+ }
+ }
+#else
for (i = 2; i < objc; i++) {
keyString = TclGetString(objv[i]);
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString);
@@ -783,45 +1029,82 @@
}
pkgPtr = Tcl_GetHashValue(hPtr);
Tcl_DeleteHashEntry(hPtr);
- if (pkgPtr->version != NULL) {
- ckfree(pkgPtr->version);
- }
- while (pkgPtr->availPtr != NULL) {
- availPtr = pkgPtr->availPtr;
- pkgPtr->availPtr = availPtr->nextPtr;
- Tcl_EventuallyFree((ClientData)availPtr->version, TCL_DYNAMIC);
- Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
- ckfree((char *) availPtr);
- }
- ckfree((char *) pkgPtr);
+ Forget (pkgPtr);
}
+#endif
break;
}
case PKG_IFNEEDED: {
int length, res;
char *argv3i, *avi;
+ /* New syntax for #339:
+ * package ifneeded -strict P V (= 5 words, fits into the check below)
+ * Old syntax:
+ * package ifneeded P V | 4
+ * package ineeded P V S | 5
+ */
+#ifdef TCL_TIP339
+ int strict = 0;
+#endif
if ((objc != 4) && (objc != 5)) {
+#ifdef TCL_TIP339
+ Tcl_WrongNumArgs(interp, 2, objv, "?-strict? package version ?script?");
+#else
Tcl_WrongNumArgs(interp, 2, objv, "package version ?script?");
+#endif
return TCL_ERROR;
}
+ argv2 = TclGetString(objv[2]);
argv3 = TclGetString(objv[3]);
+#ifdef TCL_TIP339
+ if ((objc == 5)) {
+ strict = 1;
+ if ((argv2[0] == '-') && (strcmp(argv2, "-strict") == 0)) {
+ objc--;
+ objv++;
+ argv2 = Tcl_GetString(objv[2]);
+ }
+ }
+#endif
if (CheckVersionAndConvert(interp, argv3, &argv3i, NULL) != TCL_OK) {
return TCL_ERROR;
}
- argv2 = TclGetString(objv[2]);
if (objc == 4) {
- hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
+ /*
+ * This is the form of ifneeded which queries the database for
+ * where a specific package will be loaded from. This can be
+ * non-strict.
+ */
+
+#ifdef TCL_TIP339
+ hPtr = LookupPackage(iPtr, argv2, strict);
+#else
+ hPtr = LookupPackage(iPtr, argv2);
+#endif
if (hPtr == NULL) {
ckfree(argv3i);
return TCL_OK;
}
pkgPtr = Tcl_GetHashValue(hPtr);
} else {
+ /* TIP#339 NOTE: ifneeded always searches strict, to ensure that
+ * the name matches the name used by 'provide'.
+ */
+#ifdef TCL_TIP339
+ pkgPtr = FindPackage(interp, argv2, TCL_PKG_STRICT);
+#else
pkgPtr = FindPackage(interp, argv2);
+#endif
}
argv3 = Tcl_GetStringFromObj(objv[3], &length);
+#ifdef TCL_TIP339
+ /* When non-strict we search in the equivalence class from first to
+ * last, until we find the version, or have exhausted the class.
+ */
+ do {
+#endif
for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL;
prevPtr = availPtr, availPtr = availPtr->nextPtr) {
if (CheckVersionAndConvert(interp, availPtr->version, &avi,
@@ -843,6 +1126,14 @@
break;
}
}
+#ifdef TCL_TIP339
+ if (!strict) {
+ pkgPtr = pkgPtr->nextEqPtr;
+ } else {
+ break;
+ }
+ } while (pkgPtr);
+#endif
ckfree(argv3i);
if (objc == 4) {
@@ -869,6 +1160,7 @@
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
+ /* TIP#339 NOTE: package names is unchanged */
tablePtr = &iPtr->packageTable;
for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
hPtr = Tcl_NextHashEntry(&search)) {
@@ -884,6 +1176,29 @@
goto require;
}
argv2 = TclGetString(objv[2]);
+#ifdef TCL_TIP339
+ int strict = 0;
+ exact = 0;
+
+ if ((argv2[0] == '-') && (strcmp(argv2, "-strict") == 0)) {
+ strict = TCL_PKG_STRICT;
+ objv++;
+ objc--;
+ argv2 = Tcl_GetString(objv[2]);
+ }
+ if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) {
+ if (objc != 5) {
+ goto requireSyntax;
+ }
+ exact = TCL_PKG_EXACT;
+ name = TclGetString(objv[3]);
+ } else {
+ exact = 0;
+ name = argv2;
+ }
+
+ hPtr = LookupPackage (iPtr, name, strict);
+#else
if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) {
if (objc != 5) {
goto requireSyntax;
@@ -895,7 +1210,8 @@
name = argv2;
}
- hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name);
+ hPtr = LookupPackage (iPtr, name);
+#endif
if (hPtr != NULL) {
pkgPtr = Tcl_GetHashValue(hPtr);
if (pkgPtr->version != NULL) {
@@ -919,18 +1235,51 @@
version = TclGetString(objv[3]);
}
}
+#ifdef TCL_TIP339
+ /*
+ * Munge the search flags together for propagation to the core require
+ * resolution code.
+ */
+ exact |= strict;
+#endif
Tcl_PkgPresent(interp, name, version, exact);
return TCL_ERROR;
break;
}
- case PKG_PROVIDE:
+ case PKG_PROVIDE: {
+ /* New syntax for #339:
+ * package provide -strict P (= 4 words, fits into the check below)
+ * Old syntax:
+ * package provide P V | 4
+ * package provide P | 3
+ */
+#ifdef TCL_TIP339
+ int strict = 0;
+#endif
+
if ((objc != 3) && (objc != 4)) {
+#ifdef TCL_TIP339
+ Tcl_WrongNumArgs(interp, 2, objv, "?-strict? package ?version?");
+#else
Tcl_WrongNumArgs(interp, 2, objv, "package ?version?");
+#endif
return TCL_ERROR;
}
argv2 = TclGetString(objv[2]);
+#ifdef TCL_TIP339
+ if ((objc == 4) && (argv2[0] == '-') && (strcmp(argv2, "-strict") == 0)) {
+ strict = 1;
+ objc--;
+ objv++;
+ argv2 = Tcl_GetString(objv[2]);
+ }
+#endif
if (objc == 3) {
- hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
+#ifdef TCL_TIP339
+ hPtr = LookupPackage (iPtr, argv2, strict);
+#else
+ hPtr = LookupPackage (iPtr, argv2);
+#endif
if (hPtr != NULL) {
pkgPtr = Tcl_GetHashValue(hPtr);
if (pkgPtr->version != NULL) {
@@ -943,19 +1292,37 @@
if (CheckVersionAndConvert(interp, argv3, NULL, NULL) != TCL_OK) {
return TCL_ERROR;
}
+ /* TIP#339 NOTE: nothing to be done here, always strict, and internal */
return Tcl_PkgProvide(interp, argv2, argv3);
- case PKG_REQUIRE:
+ }
+ case PKG_REQUIRE: {
+#ifdef TCL_TIP339
+ int strict = 0;
+#endif
require:
if (objc < 3) {
requireSyntax:
+#ifdef TCL_TIP339
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "?-strict? ?-exact? package ?requirement...?");
+#else
Tcl_WrongNumArgs(interp, 2, objv,
"?-exact? package ?requirement...?");
+#endif /*339*/
return TCL_ERROR;
}
version = NULL;
argv2 = TclGetString(objv[2]);
+#ifdef TCL_TIP339
+ if ((argv2[0] == '-') && (strcmp(argv2, "-strict") == 0)) {
+ strict = TCL_PKG_STRICT;
+ objv ++;
+ objc --;
+ argv2 = Tcl_GetString(objv[2]);
+ }
+#endif
if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) {
Tcl_Obj *ov;
int res;
@@ -980,7 +1347,11 @@
argv3 = TclGetString(objv[3]);
Tcl_IncrRefCount(ov);
+#ifdef TCL_TIP339
+ res = Tcl_PkgRequireProcEx(interp, argv3, 1, &ov, NULL, strict);
+#else
res = Tcl_PkgRequireProc(interp, argv3, 1, &ov, NULL);
+#endif
TclDecrRefCount(ov);
return res;
} else {
@@ -988,9 +1359,14 @@
return TCL_ERROR;
}
+#ifdef TCL_TIP339
+ return Tcl_PkgRequireProcEx(interp, argv2, objc-3, objv+3, NULL, strict);
+#else
return Tcl_PkgRequireProc(interp, argv2, objc-3, objv+3, NULL);
+#endif
}
break;
+ }
case PKG_UNKNOWN: {
int length;
@@ -1080,13 +1456,32 @@
ckfree(iva);
ckfree(ivb);
break;
- case PKG_VERSIONS:
+ case PKG_VERSIONS: {
+#ifdef TCL_TIP339
+ int strict = 0;
+ if ((objc != 3) && (objc != 4)) {
+ versions_syntax:
+ Tcl_WrongNumArgs(interp, 2, objv, "?-strict? package");
+ return TCL_ERROR;
+ }
+ argv2 = Tcl_GetString(objv[2]);
+ if (objc == 4) {
+ if ((argv2[0] == '-') && (strcmp(argv2, "-strict") == 0)) {
+ strict = 1;
+ } else {
+ goto versions_syntax;
+ }
+ argv2 = Tcl_GetString(objv[3]);
+ }
+ hPtr = LookupPackage (iPtr, argv2, strict);
+#else
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "package");
return TCL_ERROR;
}
argv2 = TclGetString(objv[2]);
- hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
+ hPtr = LookupPackage (iPtr, argv2);
+#endif
if (hPtr != NULL) {
pkgPtr = Tcl_GetHashValue(hPtr);
for (availPtr = pkgPtr->availPtr; availPtr != NULL;
@@ -1095,6 +1490,7 @@
}
}
break;
+ }
case PKG_VSATISFIES: {
char *argv2i = NULL;
@@ -1127,6 +1523,47 @@
/*
*----------------------------------------------------------------------
*
+ * LookupPackage --
+ *
+ * This procedure finds the Package record (represented by a HashEntry)
+ * for a particular package in a particular interpreter. None will be
+ * created if it doesn't exist.
+ *
+ * Results:
+ * The return value is a pointer to the Package record for the
+ * package, or NULL.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+#ifdef TCL_TIP339
+static Tcl_HashEntry *
+LookupPackage(
+ Interp *iPtr,
+ CONST char *name,
+ int strict)
+{
+ Tcl_HashEntry* hPtr;
+
+ if (strict) {
+ hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name);
+ } else {
+ char* nameLower;
+ DupString (nameLower, name);
+ Tcl_UtfToLower (nameLower);
+
+ hPtr = Tcl_FindHashEntry(&iPtr->packageTableLC, nameLower);
+ ckfree (nameLower);
+ }
+ return hPtr;
+}
+#endif
+
+/*
+ *----------------------------------------------------------------------
+ *
* FindPackage --
*
* This function finds the Package record for a particular package in a
@@ -1145,13 +1582,32 @@
static Package *
FindPackage(
Tcl_Interp *interp, /* Interpreter to use for package lookup. */
- const char *name) /* Name of package to fine. */
+ const char *name /* Name of package to fine. */
+#ifdef TCL_TIP339
+ , int strict /* Boolean flag. Set if strict matching is required */
+#endif
+ )
{
Interp *iPtr = (Interp *) interp;
Tcl_HashEntry *hPtr;
int isNew;
Package *pkgPtr;
+#ifdef TCL_TIP339
+ /* Find and create ... That is a bit of a problem ...
+ *
+ * ... strict ... look and create in regular table ...
+ * ... ...... ... if new => create in lc table ...
+ * ... ...... ... ... if !new - extend eq. list ...
+ * .............. return regular pkg ptr.
+ *
+ * !strict ... look and create in regular table ... -> new
+ * ........... look and create in lc table ... -> new'
+ * ........... new' => return created ...
+ * ........... !new' && new => extend eq list, and return first.
+ */
+#endif
+
hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &isNew);
if (isNew) {
pkgPtr = (Package *) ckalloc(sizeof(Package));
@@ -1159,9 +1615,60 @@
pkgPtr->availPtr = NULL;
pkgPtr->clientData = NULL;
Tcl_SetHashValue(hPtr, pkgPtr);
+
+#ifdef TCL_TIP339
+ pkgPtr->myHEPtr = hPtr;
+ pkgPtr->myHEPtrLC = NULL;
+ pkgPtr->firstEqPtr = pkgPtr;
+ pkgPtr->lastEqPtr = NULL;
+ pkgPtr->nextEqPtr = NULL;
+#endif
} else {
pkgPtr = Tcl_GetHashValue(hPtr);
}
+
+#ifdef TCL_TIP339
+ {
+ char* nameLower;
+ DupString (nameLower, name);
+ Tcl_UtfToLower (nameLower);
+ int isNewLC;
+
+ hPtr = Tcl_CreateHashEntry(&iPtr->packageTableLC, nameLower, &isNewLC);
+ ckfree ((char*) nameLower);
+
+ if (!isNewLC) {
+ Package *pkgLCPtr = (Package *) Tcl_GetHashValue(hPtr);
+
+ if (isNew) {
+ /*
+ * The class list has to be extended if and only if the
+ * package name is strictly new.
+ */
+
+ if (!pkgLCPtr->nextEqPtr) {
+ pkgLCPtr->nextEqPtr = pkgPtr;
+ } else {
+ pkgLCPtr->lastEqPtr->nextEqPtr = pkgPtr;
+ }
+ pkgLCPtr->lastEqPtr = pkgPtr;
+ pkgPtr->firstEqPtr = pkgLCPtr;
+ }
+
+ if (!strict) {
+ /* Non strict match. Return first in LC table instead of the
+ * exact entry we had.
+ */
+
+ pkgPtr = pkgLCPtr;
+ }
+ } else {
+ pkgPtr->myHEPtrLC = hPtr;
+ Tcl_SetHashValue(hPtr, pkgPtr);
+ }
+ }
+#endif
+
return pkgPtr;
}
@@ -1207,6 +1714,14 @@
ckfree((char *) pkgPtr);
}
Tcl_DeleteHashTable(&iPtr->packageTable);
+#ifdef TCL_TIP339
+ /* Note: The contents (struct Package) have already been removed as part
+ * of deleting the regular table, see above. This table shared the
+ * pointers and contained only a subset.
+ */
+ Tcl_DeleteHashTable(&iPtr->packageTableLC);
+#endif
+
if (iPtr->packageUnknown != NULL) {
ckfree(iPtr->packageUnknown);
}
--- tcl85.orig/generic/tclStubInit.c 2008-11-18 09:09:56.000000000 -0800
+++ tcl85/generic/tclStubInit.c 2008-11-21 15:38:22.000000000 -0800
@@ -1128,6 +1128,32 @@
Tcl_AppendFormatToObj, /* 577 */
Tcl_ObjPrintf, /* 578 */
Tcl_AppendPrintfToObj, /* 579 */
+ NULL, /* 580 */
+ NULL, /* 581 */
+ NULL, /* 582 */
+ NULL, /* 583 */
+ NULL, /* 584 */
+ NULL, /* 585 */
+ NULL, /* 586 */
+ NULL, /* 587 */
+ NULL, /* 588 */
+ NULL, /* 589 */
+ NULL, /* 590 */
+ NULL, /* 591 */
+ NULL, /* 592 */
+ NULL, /* 593 */
+ NULL, /* 594 */
+ NULL, /* 595 */
+ NULL, /* 596 */
+ NULL, /* 597 */
+ NULL, /* 598 */
+ NULL, /* 599 */
+ NULL, /* 600 */
+ NULL, /* 601 */
+ NULL, /* 602 */
+ NULL, /* 603 */
+ NULL, /* 604 */
+ Tcl_PkgRequireProcEx, /* 605 */
};
/* !END!: Do not edit above this line. */
--- tcl85.orig/generic/tclTest.c 2008-11-18 09:09:56.000000000 -0800
+++ tcl85/generic/tclTest.c 2008-11-21 14:33:59.000000000 -0800
@@ -559,9 +559,14 @@
"-appinitprocclosestderr", "-appinitprocsetrcfile", NULL
};
+#ifdef TCL_TIP339
+#define TCLTEST_APPPKG "TcltestApp"
+#else
+#define TCLTEST_APPPKG "Tcltest"
+#endif
/* TIP #268: Full patchlevel instead of just major.minor */
- if (Tcl_PkgProvide(interp, "Tcltest", TCL_PATCH_LEVEL) == TCL_ERROR) {
+ if (Tcl_PkgProvide(interp, TCLTEST_APPPKG, TCL_PATCH_LEVEL) == TCL_ERROR) {
return TCL_ERROR;
}
--- tcl85.orig/library/tm.tcl 2008-11-18 09:09:55.000000000 -0800
+++ tcl85/library/tm.tcl 2008-11-26 14:54:28.000000000 -0800
@@ -217,8 +217,7 @@
if {![interp issafe] && ![file exists $path]} {
continue
}
- set currentsearchpath [file join $path $pkgroot]
- if {![interp issafe] && ![file exists $currentsearchpath]} {
+ if {![interp issafe] && ![FileExists $path $pkgroot currentsearchpath]} {
continue
}
set strip [llength [file split $path]]
@@ -232,7 +231,15 @@
catch {
# We always look for _all_ possible modules in the current
- # path, to get the max result out of the glob.
+ # path, to get the best result out of a single glob.
+
+ # NOTE regarding TIP 339: The currentsearchpath was
+ # identified via case-insensitive search (see
+ # implementation of FileExists below, as used above)
+ # and can now be used case-sensitive. The pattern for
+ # the contents has no alphanumeric, so no case-issues
+ # there either. No changes are needed for the inner
+ # loop.
foreach file [glob -nocomplain -directory $currentsearchpath *.tm] {
set pkgfilename [join [lrange [file split $file] $strip end] ::]
@@ -374,6 +381,68 @@
return
}
+# TIP 339 support.
+if {$tcl_platform(platform) eq "windows"} {
+ # On windows we can use the regular operations, they are
+ # case-insensitive.
+ proc ::tcl::tm::FileExists {base path rv} {
+ upvar $rv result
+ set result [file join $base $path]
+ return [file exists $result]
+ }
+} else {
+ # On unix we have to search ourselves to get the case-insensitve
+ # matching we want.
+
+ proc ::tcl::tm::FileExists {base path rv} {
+ upvar 1 $rv result
+ set path [file split $path]
+
+ # Unix. We glob down the path forcing case insensitive
+ # matching by constructing a proper pattern. We claim
+ # non-existence not only when we find nothing, but also when
+ # we find multiple possibilities. The latter as it indicates a
+ # violation of the TIP, namely that module names may no
+ # conflict case-insensitively.
+
+ while {[llength $path]} {
+ set rc [glob -nocomplain -directory $base [Pattern [lindex $path 0]]]
+
+ if {![llength $rc] || ([llength $rc] > 1)} {
+ # No match, or too many => consider both as
+ # non-existing. TIP 189 said that multiple modules
+ # using same name, but different case in their names
+ # are not allowed.
+ return 0
+ }
+ # Push the one and only possibility to the base and go to
+ # the next segment for the next round.
+ set base [file join [lindex $rc 0]]
+ set path [lrange $path 1 end]
+ }
+ # The final base is what we need later.
+ set result $base
+ return 1
+ }
+
+ proc ::tcl::tm::Pattern {path} {
+ set res ""
+ foreach c [split $path {}] {
+ set cu [string toupper $c]
+ set cl [string tolower $c]
+ if {$cu eq $cl} {
+ # A character which has no different cases remains as
+ # is.
+ append res $c
+ } else {
+ # A character with multiple cases, we look for both,
+ # use a glob character-class
+ append res "\[$cu$cl\]"
+ }
+ }
+ }
+}
+
# Initialization. Set up the default paths, then insert the new
# handler into the chain.
--- tcl85.orig/tests/pkg.test 2008-11-18 09:09:54.000000000 -0800
+++ tcl85/tests/pkg.test 2008-11-21 16:19:24.000000000 -0800
@@ -32,6 +32,9 @@
set oldPath $auto_path
set auto_path ""
+testConstraint tip339 [info exists tcl_platform(tip,339)]
+testConstraint !tip339 [expr {![info exists tcl_platform(tip,339)]}]
+
test pkg-1.1 {Tcl_PkgProvide procedure} {
package forget t
package provide t 2.3
@@ -570,12 +573,18 @@
package forget a
set x
} {}
-test pkg-3.6 {Tcl_PackageCmd procedure, "ifneeded" option} {
+test pkg-3.6 {Tcl_PackageCmd procedure, "ifneeded" option} !tip339 {
list [catch {package ifneeded a} msg] $msg
} {1 {wrong # args: should be "package ifneeded package version ?script?"}}
-test pkg-3.7 {Tcl_PackageCmd procedure, "ifneeded" option} {
+test pkg-3.6-339 {Tcl_PackageCmd procedure, "ifneeded" option} tip339 {
+ list [catch {package ifneeded a} msg] $msg
+} {1 {wrong # args: should be "package ifneeded ?-strict? package version ?script?"}}
+test pkg-3.7 {Tcl_PackageCmd procedure, "ifneeded" option} !tip339 {
list [catch {package ifneeded a b c d} msg] $msg
} {1 {wrong # args: should be "package ifneeded package version ?script?"}}
+test pkg-3.7-339 {Tcl_PackageCmd procedure, "ifneeded" option} tip339 {
+ list [catch {package ifneeded a b c d} msg] $msg
+} {1 {wrong # args: should be "package ifneeded ?-strict? package version ?script?"}}
test pkg-3.8 {Tcl_PackageCmd procedure, "ifneeded" option} {
list [catch {package ifneeded t xyz} msg] $msg
} {1 {expected version number but got "xyz"}}
@@ -627,12 +636,18 @@
catch {package require z 47.16}
lsort [package names]
} {x y}
-test pkg-3.17 {Tcl_PackageCmd procedure, "provide" option} {
+test pkg-3.17 {Tcl_PackageCmd procedure, "provide" option} !tip339 {
list [catch {package provide} msg] $msg
} {1 {wrong # args: should be "package provide package ?version?"}}
-test pkg-3.18 {Tcl_PackageCmd procedure, "provide" option} {
+test pkg-3.17-339 {Tcl_PackageCmd procedure, "provide" option} tip339 {
+ list [catch {package provide} msg] $msg
+} {1 {wrong # args: should be "package provide ?-strict? package ?version?"}}
+test pkg-3.18 {Tcl_PackageCmd procedure, "provide" option} !tip339 {
list [catch {package provide a b c} msg] $msg
} {1 {wrong # args: should be "package provide package ?version?"}}
+test pkg-3.18-339 {Tcl_PackageCmd procedure, "provide" option} tip339 {
+ list [catch {package provide a b c} msg] $msg
+} {1 {wrong # args: should be "package provide ?-strict? package ?version?"}}
test pkg-3.19 {Tcl_PackageCmd procedure, "provide" option} {
package forget t
package provide t
@@ -646,15 +661,23 @@
package forget t
list [catch {package provide t a.b} msg] $msg
} {1 {expected version number but got "a.b"}}
-test pkg-3.22 {Tcl_PackageCmd procedure, "require" option} {
+test pkg-3.22 {Tcl_PackageCmd procedure, "require" option} !tip339 {
list [catch {package require} msg] $msg
} {1 {wrong # args: should be "package require ?-exact? package ?requirement...?"}}
+test pkg-3.22-339 {Tcl_PackageCmd procedure, "require" option} tip339 {
+ list [catch {package require} msg] $msg
+} {1 {wrong # args: should be "package require ?-strict? ?-exact? package ?requirement...?"}}
-test pkg-3.24 {Tcl_PackageCmd procedure, "require" option} {
+test pkg-3.24 {Tcl_PackageCmd procedure, "require" option} !tip339 {
list [catch {package require -exact a b c} msg] $msg
# Exact syntax: -exact name version
# name ?requirement...?
} {1 {wrong # args: should be "package require ?-exact? package ?requirement...?"}}
+test pkg-3.24-339 {Tcl_PackageCmd procedure, "require" option} tip339 {
+ list [catch {package require -exact a b c} msg] $msg
+ # Exact syntax: -exact name version
+ # name ?requirement...?
+} {1 {wrong # args: should be "package require ?-strict? ?-exact? package ?requirement...?"}}
test pkg-3.26 {Tcl_PackageCmd procedure, "require" option} {
list [catch {package require x a.b} msg] $msg
@@ -662,12 +685,18 @@
test pkg-3.27 {Tcl_PackageCmd procedure, "require" option} {
list [catch {package require -exact x a.b} msg] $msg
} {1 {expected version number but got "a.b"}}
-test pkg-3.28 {Tcl_PackageCmd procedure, "require" option} {
+test pkg-3.28 {Tcl_PackageCmd procedure, "require" option} !tip339 {
list [catch {package require -exact x} msg] $msg
} {1 {wrong # args: should be "package require ?-exact? package ?requirement...?"}}
-test pkg-3.29 {Tcl_PackageCmd procedure, "require" option} {
+test pkg-3.28-339 {Tcl_PackageCmd procedure, "require" option} tip339 {
+ list [catch {package require -exact x} msg] $msg
+} {1 {wrong # args: should be "package require ?-strict? ?-exact? package ?requirement...?"}}
+test pkg-3.29 {Tcl_PackageCmd procedure, "require" option} !tip339 {
list [catch {package require -exact} msg] $msg
} {1 {wrong # args: should be "package require ?-exact? package ?requirement...?"}}
+test pkg-3.29-339 {Tcl_PackageCmd procedure, "require" option} tip339 {
+ list [catch {package require -exact} msg] $msg
+} {1 {wrong # args: should be "package require ?-strict? ?-exact? package ?requirement...?"}}
test pkg-3.30 {Tcl_PackageCmd procedure, "require" option} {
package forget t
package provide t 2.3
@@ -712,12 +741,18 @@
test pkg-3.41 {Tcl_PackageCmd procedure, "vcompare" option} {
package vc 2.2.4 2.2.4
} {0}
-test pkg-3.42 {Tcl_PackageCmd procedure, "versions" option} {
+test pkg-3.42 {Tcl_PackageCmd procedure, "versions" option} !tip339 {
list [catch {package versions} msg] $msg
} {1 {wrong # args: should be "package versions package"}}
-test pkg-3.43 {Tcl_PackageCmd procedure, "versions" option} {
+test pkg-3.42-339 {Tcl_PackageCmd procedure, "versions" option} tip339 {
+ list [catch {package versions} msg] $msg
+} {1 {wrong # args: should be "package versions ?-strict? package"}}
+test pkg-3.43 {Tcl_PackageCmd procedure, "versions" option} !tip339 {
list [catch {package versions a b} msg] $msg
} {1 {wrong # args: should be "package versions package"}}
+test pkg-3.43-339 {Tcl_PackageCmd procedure, "versions" option} tip339 {
+ list [catch {package versions a b} msg] $msg
+} {1 {wrong # args: should be "package versions ?-strict? package"}}
test pkg-3.44 {Tcl_PackageCmd procedure, "versions" option} {
package forget t
package versions t
@@ -886,15 +921,21 @@
package forget t
list [catch {package present -exact t 2.4} msg] $msg
} {1 {package t 2.4 is not present}}
-test pkg-7.11 {Tcl_PackageCmd procedure, "present" option} {
+test pkg-7.11 {Tcl_PackageCmd procedure, "present" option} !tip339 {
list [catch {package present} msg] $msg
} {1 {wrong # args: should be "package present ?-exact? package ?requirement...?"}}
+test pkg-7.11-339 {Tcl_PackageCmd procedure, "present" option} tip339 {
+ list [catch {package present} msg] $msg
+} {1 {wrong # args: should be "package present ?-strict? ?-exact? package ?requirement...?"}}
test pkg-7.12 {Tcl_PackageCmd procedure, "present" option} {
list [catch {package present a b c} msg] $msg
} {1 {expected version number but got "b"}}
-test pkg-7.13 {Tcl_PackageCmd procedure, "present" option} {
+test pkg-7.13 {Tcl_PackageCmd procedure, "present" option} !tip339 {
list [catch {package present -exact a b c} msg] $msg
} {1 {wrong # args: should be "package present ?-exact? package ?requirement...?"}}
+test pkg-7.13-339 {Tcl_PackageCmd procedure, "present" option} tip339 {
+ list [catch {package present -exact a b c} msg] $msg
+} {1 {wrong # args: should be "package present ?-strict? ?-exact? package ?requirement...?"}}
test pkg-7.14 {Tcl_PackageCmd procedure, "present" option} {
list [catch {package present -bs a b} msg] $msg
} {1 {expected version number but got "a"}}
@@ -904,12 +945,18 @@
test pkg-7.16 {Tcl_PackageCmd procedure, "present" option} {
list [catch {package present -exact x a.b} msg] $msg
} {1 {expected version number but got "a.b"}}
-test pkg-7.17 {Tcl_PackageCmd procedure, "present" option} {
+test pkg-7.17 {Tcl_PackageCmd procedure, "present" option} !tip339 {
list [catch {package present -exact x} msg] $msg
} {1 {wrong # args: should be "package present ?-exact? package ?requirement...?"}}
-test pkg-7.18 {Tcl_PackageCmd procedure, "present" option} {
+test pkg-7.17-339 {Tcl_PackageCmd procedure, "present" option} tip339 {
+ list [catch {package present -exact x} msg] $msg
+} {1 {wrong # args: should be "package present ?-strict? ?-exact? package ?requirement...?"}}
+test pkg-7.18 {Tcl_PackageCmd procedure, "present" option} !tip339 {
list [catch {package present -exact} msg] $msg
} {1 {wrong # args: should be "package present ?-exact? package ?requirement...?"}}
+test pkg-7.18-339 {Tcl_PackageCmd procedure, "present" option} tip339 {
+ list [catch {package present -exact} msg] $msg
+} {1 {wrong # args: should be "package present ?-strict? ?-exact? package ?requirement...?"}}
--- tcl85.orig/tests/platform.test 2008-11-18 09:09:54.000000000 -0800
+++ tcl85/tests/platform.test 2008-11-21 14:32:39.000000000 -0800
@@ -22,6 +22,7 @@
interp create i
i eval {catch {unset tcl_platform(debug)}}
i eval {catch {unset tcl_platform(threaded)}}
+ i eval {catch {unset tcl_platform(tip,339)}}
set result [i eval {lsort [array names tcl_platform]}]
interp delete i
set result
--- tcl85.orig/tests/safe.test 2008-11-18 09:09:54.000000000 -0800
+++ tcl85/tests/safe.test 2008-11-21 14:31:51.000000000 -0800
@@ -183,6 +183,10 @@
if {$threaded != -1} {
set r [lreplace $r $threaded $threaded]
}
+ set tip [lsearch $r "tip,339"]
+ if {$tip != -1} {
+ set r [lreplace $r $tip $tip]
+ }
set r
} {byteOrder platform pointerSize wordSize}
