Attachment "tip-339-tcl86.patch" to
ticket [2316115fff]
added by
andreas_kupries
2008-11-27 05:58:19.
--- tcl86.orig/generic/tclBasic.c 2008-11-18 09:10:04.000000000 -0800
+++ tcl86/generic/tclBasic.c 2008-11-24 11:10:43.000000000 -0800
@@ -535,6 +535,7 @@
iPtr->appendUsed = 0;
Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS);
+ Tcl_InitHashTable(&iPtr->packageTableLC, TCL_STRING_KEYS);
iPtr->packageUnknown = NULL;
/* TIP #268 */
--- tcl86.orig/generic/tcl.decls 2008-11-18 09:15:02.000000000 -0800
+++ tcl86/generic/tcl.decls 2008-11-24 11:11:04.000000000 -0800
@@ -2204,6 +2204,15 @@
int *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv)
}
+# 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
--- tcl86.orig/generic/tclDecls.h 2008-11-18 09:15:02.000000000 -0800
+++ tcl86/generic/tclDecls.h 2008-11-24 12:14:51.000000000 -0800
@@ -3657,6 +3657,14 @@
const Tcl_ArgvInfo * argTable, int * objcPtr,
Tcl_Obj *const * objv, Tcl_Obj *** remObjv);
#endif
+#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 {
const struct TclPlatStubs *tclPlatStubs;
@@ -4321,6 +4329,7 @@
int (*tcl_SetEnsembleParameterList) (Tcl_Interp * interp, Tcl_Command token, Tcl_Obj * paramList); /* 602 */
int (*tcl_GetEnsembleParameterList) (Tcl_Interp * interp, Tcl_Command token, Tcl_Obj ** paramListPtr); /* 603 */
int (*tcl_ParseArgsObjv) (Tcl_Interp * interp, const Tcl_ArgvInfo * argTable, int * objcPtr, Tcl_Obj *const * objv, Tcl_Obj *** remObjv); /* 604 */
+ int (*tcl_PkgRequireProcEx) (Tcl_Interp * interp, CONST char * name, int objc, Tcl_Obj *CONST objv[], ClientData * clientDataPtr, int flags); /* 605 */
} TclStubs;
#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
@@ -6813,6 +6822,10 @@
#define Tcl_ParseArgsObjv \
(tclStubsPtr->tcl_ParseArgsObjv) /* 604 */
#endif
+#ifndef Tcl_PkgRequireProcEx
+#define Tcl_PkgRequireProcEx \
+ (tclStubsPtr->tcl_PkgRequireProcEx) /* 605 */
+#endif
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
--- tcl86.orig/generic/tcl.h 2008-11-18 09:15:02.000000000 -0800
+++ tcl86/generic/tcl.h 2008-11-24 11:12:24.000000000 -0800
@@ -2152,6 +2152,13 @@
#endif
/*
+ * TIP #339.
+ * 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 */
+
+/*
* TIP #59: The following structure is used in calls 'Tcl_RegisterConfig' to
* provide the system with the embedded configuration data.
*/
--- tcl86.orig/generic/tclInt.h 2008-11-18 09:15:02.000000000 -0800
+++ tcl86/generic/tclInt.h 2008-11-24 11:13:06.000000000 -0800
@@ -1756,6 +1756,14 @@
* commands for packages that aren't described
* in packageTable. Ckalloc'ed, may be
* NULL. */
+ 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
+ */
/*
* Miscellaneous information:
*/
--- tcl86.orig/generic/tclPkg.c 2008-11-18 09:10:04.000000000 -0800
+++ tcl86/generic/tclPkg.c 2008-11-24 12:17:43.000000000 -0800
@@ -49,6 +49,17 @@
PkgAvail *availPtr; /* First in list of all available versions of
* this package. */
ClientData clientData; /* Client data. */
+
+ /* TIP #339 */
+ 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. */
} Package;
/*
@@ -70,10 +81,13 @@
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 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);
+ ClientData *clientDataPtr, int strict);
+
+/* TIP #339 */
+static Tcl_HashEntry * LookupPackage(Interp *iPtr, const char *name, int strict);
/*
* Helper macros.
@@ -131,13 +145,21 @@
char *pvi, *vi;
int res;
- pkgPtr = FindPackage(interp, name);
+ pkgPtr = FindPackage(interp, name, TCL_PKG_STRICT);
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;
@@ -209,9 +231,14 @@
const char *name, /* Name of desired package. */
const char *version, /* Version string for desired version; NULL
* means use the latest version available. */
- int exact, /* Non-zero means that only the particular
- * version given is acceptable. Zero means use
- * the latest compatible version. */
+ int flags, /* Bit field. Flags are TCL_PKG_EXACT,
+ * TCL_PKG_STRICT. TCL_PKG_EXACT means that
+ * only the particular version given is
+ * acceptable. Otherwise use the latest
+ * compatible version. TCL_PKG_STRICT means
+ * that string comparison has to be
+ * case-sensitive. Otherwise ignore case in
+ * package names. */
ClientData *clientDataPtr) /* Used to return the client data for this
* package. If it is NULL then the client data
* is not returned. This is unchanged if this
@@ -296,18 +323,20 @@
*/
if (version == NULL) {
- result = PkgRequireCore(interp, name, 0, NULL, clientDataPtr);
+ result = PkgRequireCore(interp, name, 0, NULL, clientDataPtr,
+ flags & TCL_PKG_STRICT);
} else {
- if (exact && TCL_OK
+ if ((flags & TCL_PKG_EXACT) && TCL_OK
!= CheckVersionAndConvert(interp, version, NULL, NULL)) {
return NULL;
}
ov = Tcl_NewStringObj(version, -1);
- if (exact) {
+ if (flags & TCL_PKG_EXACT) {
Tcl_AppendStringsToObj(ov, "-", version, NULL);
}
Tcl_IncrRefCount(ov);
- result = PkgRequireCore(interp, name, 1, &ov, clientDataPtr);
+ result = PkgRequireCore(interp, name, 1, &ov, clientDataPtr,
+ flags & TCL_PKG_STRICT);
TclDecrRefCount(ov);
}
@@ -325,8 +354,23 @@
* available. */
ClientData *clientDataPtr)
{
+ 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);
+ PkgRequireCore(interp, name, reqc, reqv, clientDataPtr, flags & TCL_PKG_STRICT);
if (result == NULL) {
return TCL_ERROR;
@@ -344,7 +388,8 @@
* version. */
Tcl_Obj *const reqv[], /* 0 means to use the latest version
* available. */
- ClientData *clientDataPtr)
+ ClientData *clientDataPtr,
+ int flags) /* TCL_PKG_STRICT package search or not ? */
{
Interp *iPtr = (Interp *) interp;
Package *pkgPtr;
@@ -363,7 +408,7 @@
*/
for (pass=1 ;; pass++) {
- pkgPtr = FindPackage(interp, name);
+ pkgPtr = FindPackage(interp, name, flags);
if (pkgPtr->version != NULL) {
break;
}
@@ -486,7 +531,7 @@
code = Tcl_EvalEx(interp, script, -1, TCL_EVAL_GLOBAL);
Tcl_Release((ClientData) script);
- pkgPtr = FindPackage(interp, name);
+ pkgPtr = FindPackage(interp, name, flags);
if (code == TCL_OK) {
Tcl_ResetResult(interp);
if (pkgPtr->version == NULL) {
@@ -660,11 +705,16 @@
const char *name, /* Name of desired package. */
const char *version, /* Version string for desired version; NULL
* means use the latest version available. */
- int exact) /* Non-zero means that only the particular
- * version given is acceptable. Zero means use
- * the latest compatible version. */
+ int flags) /* Bit field. Flags are TCL_PKG_EXACT,
+ * TCL_PKG_STRICT. TCL_PKG_EXACT means that
+ * only the particular version given is
+ * acceptable. Otherwise use the latest
+ * compatible version. TCL_PKG_STRICT means
+ * that string comparison has to be
+ * case-sensitive. Otherwise ignore case in
+ * package names. */
{
- return Tcl_PkgPresentEx(interp, name, version, exact, NULL);
+ return Tcl_PkgPresentEx(interp, name, version, flags, NULL);
}
const char *
@@ -674,9 +724,14 @@
const char *name, /* Name of desired package. */
const char *version, /* Version string for desired version; NULL
* means use the latest version available. */
- int exact, /* Non-zero means that only the particular
- * version given is acceptable. Zero means use
- * the latest compatible version. */
+ int flags, /* Bit field. Flags are TCL_PKG_EXACT,
+ * TCL_PKG_STRICT. TCL_PKG_EXACT means that
+ * only the particular version given is
+ * acceptable. Otherwise use the latest
+ * compatible version. TCL_PKG_STRICT means
+ * that string comparison has to be
+ * case-sensitive. Otherwise ignore case in
+ * package names. */
ClientData *clientDataPtr) /* Used to return the client data for this
* package. If it is NULL then the client data
* is not returned. This is unchanged if this
@@ -686,7 +741,7 @@
Tcl_HashEntry *hPtr;
Package *pkgPtr;
- hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name);
+ hPtr = LookupPackage (iPtr, name, flags & TCL_PKG_STRICT);
if (hPtr) {
pkgPtr = Tcl_GetHashValue(hPtr);
if (pkgPtr->version != NULL) {
@@ -697,7 +752,7 @@
*/
const char *foundVersion = Tcl_PkgRequireEx(interp, name, version,
- exact, clientDataPtr);
+ flags, clientDataPtr);
if (foundVersion == NULL) {
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PACKAGE", name,
@@ -734,6 +789,34 @@
*----------------------------------------------------------------------
*/
+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);
+}
+
+
+static Package*
+GetPrevious (Package *pkgPtr, Package* findPtr)
+{
+ while (pkgPtr->nextEqPtr != findPtr) {
+ pkgPtr = pkgPtr->nextEqPtr;
+ }
+ return pkgPtr;
+}
+
/* ARGSUSED */
int
Tcl_PackageObjCmd(
@@ -775,53 +858,153 @@
case PKG_FORGET: {
char *keyString;
- for (i = 2; i < objc; i++) {
- keyString = TclGetString(objv[i]);
- hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString);
+ 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 = Tcl_GetHashValue(hPtr);
+
+ 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);
- if (pkgPtr->version != NULL) {
- ckfree(pkgPtr->version);
+ 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;
}
- while (pkgPtr->availPtr != NULL) {
- availPtr = pkgPtr->availPtr;
- pkgPtr->availPtr = availPtr->nextPtr;
- Tcl_EventuallyFree((ClientData)availPtr->version, TCL_DYNAMIC);
- Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
- ckfree((char *) availPtr);
}
- ckfree((char *) pkgPtr);
}
break;
}
case PKG_IFNEEDED: {
int length, 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
+ */
+ int strict = 0;
if ((objc != 4) && (objc != 5)) {
- Tcl_WrongNumArgs(interp, 2, objv, "package version ?script?");
+ Tcl_WrongNumArgs(interp, 2, objv, "?-strict? package version ?script?");
return TCL_ERROR;
}
+ argv2 = TclGetString(objv[2]);
argv3 = TclGetString(objv[3]);
+ if ((objc == 5)) {
+ strict = 1;
+ if ((argv2[0] == '-') && (strcmp(argv2, "-strict") == 0)) {
+ objc--;
+ objv++;
+ argv2 = Tcl_GetString(objv[2]);
+ }
+ }
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.
+ */
+
+ hPtr = LookupPackage(iPtr, argv2, strict);
if (hPtr == NULL) {
ckfree(argv3i);
return TCL_OK;
}
pkgPtr = Tcl_GetHashValue(hPtr);
} else {
- pkgPtr = FindPackage(interp, argv2);
+ /* TIP#339 NOTE: ifneeded always searches strict, to ensure that
+ * the name matches the name used by 'provide'.
+ */
+ pkgPtr = FindPackage(interp, argv2, TCL_PKG_STRICT);
}
argv3 = Tcl_GetStringFromObj(objv[3], &length);
+ /* When non-strict we search in the equivalence class from first to
+ * last, until we find the version, or have exhausted the class.
+ */
+ do {
for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL;
prevPtr = availPtr, availPtr = availPtr->nextPtr) {
if (CheckVersionAndConvert(interp, availPtr->version, &avi,
@@ -843,6 +1026,12 @@
break;
}
}
+ if (!strict) {
+ pkgPtr = pkgPtr->nextEqPtr;
+ } else {
+ break;
+ }
+ } while (pkgPtr);
ckfree(argv3i);
if (objc == 4) {
@@ -869,6 +1058,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,18 +1074,27 @@
goto require;
}
argv2 = TclGetString(objv[2]);
+ 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 = 1;
+ exact = TCL_PKG_EXACT;
name = TclGetString(objv[3]);
} else {
exact = 0;
name = argv2;
}
- hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name);
+ hPtr = LookupPackage (iPtr, name, strict);
if (hPtr != NULL) {
pkgPtr = Tcl_GetHashValue(hPtr);
if (pkgPtr->version != NULL) {
@@ -919,18 +1118,35 @@
version = TclGetString(objv[3]);
}
}
- Tcl_PkgPresent(interp, name, version, exact);
+ /*
+ * Munge the search flags together for propagation to the core require
+ * resolution code.
+ */
+ Tcl_PkgPresent(interp, name, version, exact|strict);
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
+ */
+ int strict = 0;
if ((objc != 3) && (objc != 4)) {
- Tcl_WrongNumArgs(interp, 2, objv, "package ?version?");
+ Tcl_WrongNumArgs(interp, 2, objv, "?-strict? package ?version?");
return TCL_ERROR;
}
argv2 = TclGetString(objv[2]);
+ if ((objc == 4) && (argv2[0] == '-') && (strcmp(argv2, "-strict") == 0)) {
+ strict = 1;
+ objc--;
+ objv++;
+ argv2 = Tcl_GetString(objv[2]);
+ }
if (objc == 3) {
- hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
+ hPtr = LookupPackage (iPtr, argv2, strict);
if (hPtr != NULL) {
pkgPtr = Tcl_GetHashValue(hPtr);
if (pkgPtr->version != NULL) {
@@ -943,19 +1159,28 @@
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: {
+ int strict = 0;
require:
if (objc < 3) {
requireSyntax:
Tcl_WrongNumArgs(interp, 2, objv,
- "?-exact? package ?requirement ...?");
+ "?-strict? ?-exact? package ?requirement ...?");
return TCL_ERROR;
}
version = NULL;
argv2 = TclGetString(objv[2]);
+ 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)) {
Tcl_Obj *ov;
int res;
@@ -980,7 +1205,7 @@
argv3 = TclGetString(objv[3]);
Tcl_IncrRefCount(ov);
- res = Tcl_PkgRequireProc(interp, argv3, 1, &ov, NULL);
+ res = Tcl_PkgRequireProcEx(interp, argv3, 1, &ov, NULL, strict);
TclDecrRefCount(ov);
return res;
} else {
@@ -988,9 +1213,10 @@
return TCL_ERROR;
}
- return Tcl_PkgRequireProc(interp, argv2, objc-3, objv+3, NULL);
+ return Tcl_PkgRequireProcEx(interp, argv2, objc-3, objv+3, NULL, strict);
}
break;
+ }
case PKG_UNKNOWN: {
int length;
@@ -1080,13 +1306,23 @@
ckfree(iva);
ckfree(ivb);
break;
- case PKG_VERSIONS:
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "package");
+ case PKG_VERSIONS: {
+ int strict = 0;
+ if ((objc != 3) && (objc != 4)) {
+ versions_syntax:
+ Tcl_WrongNumArgs(interp, 2, objv, "?-strict? package");
return TCL_ERROR;
}
- argv2 = TclGetString(objv[2]);
- hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
+ 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);
if (hPtr != NULL) {
pkgPtr = Tcl_GetHashValue(hPtr);
for (availPtr = pkgPtr->availPtr; availPtr != NULL;
@@ -1095,6 +1331,7 @@
}
}
break;
+ }
case PKG_VSATISFIES: {
char *argv2i = NULL;
@@ -1127,6 +1364,45 @@
/*
*----------------------------------------------------------------------
*
+ * 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.
+ *
+ *----------------------------------------------------------------------
+ */
+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;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* FindPackage --
*
* This function finds the Package record for a particular package in a
@@ -1145,12 +1421,28 @@
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 find. */
+ int strict) /* Boolean flag. Set if case-sensitive matching is required */
{
Interp *iPtr = (Interp *) interp;
Tcl_HashEntry *hPtr;
int isNew;
Package *pkgPtr;
+ char* nameLower;
+ int isNewLC;
+
+ /* 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.
+ */
hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &isNew);
if (isNew) {
@@ -1159,9 +1451,53 @@
pkgPtr->availPtr = NULL;
pkgPtr->clientData = NULL;
Tcl_SetHashValue(hPtr, pkgPtr);
+
+ pkgPtr->myHEPtr = hPtr;
+ pkgPtr->myHEPtrLC = NULL;
+ pkgPtr->firstEqPtr = pkgPtr;
+ pkgPtr->lastEqPtr = NULL;
+ pkgPtr->nextEqPtr = NULL;
} else {
pkgPtr = Tcl_GetHashValue(hPtr);
}
+
+ /* TIP #339 */
+ DupString (nameLower, name);
+ Tcl_UtfToLower (nameLower);
+
+ 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);
+ }
+
return pkgPtr;
}
@@ -1207,6 +1543,13 @@
ckfree((char *) pkgPtr);
}
Tcl_DeleteHashTable(&iPtr->packageTable);
+ /*
+ * TIP #339.
+ * 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);
if (iPtr->packageUnknown != NULL) {
ckfree(iPtr->packageUnknown);
}
--- tcl86.orig/generic/tclStubInit.c 2008-11-18 09:10:04.000000000 -0800
+++ tcl86/generic/tclStubInit.c 2008-11-24 12:14:52.000000000 -0800
@@ -1130,6 +1130,7 @@
Tcl_SetEnsembleParameterList, /* 602 */
Tcl_GetEnsembleParameterList, /* 603 */
Tcl_ParseArgsObjv, /* 604 */
+ Tcl_PkgRequireProcEx, /* 605 */
};
/* !END!: Do not edit above this line. */
--- tcl86.orig/generic/tclTest.c 2008-11-25 09:26:10.000000000 -0800
+++ tcl86/generic/tclTest.c 2008-11-25 09:26:00.000000000 -0800
@@ -534,7 +534,7 @@
/* TIP #268: Full patchlevel instead of just major.minor */
- if (Tcl_PkgProvide(interp, "Tcltest", TCL_PATCH_LEVEL) == TCL_ERROR) {
+ if (Tcl_PkgProvide(interp, "TcltestApp", TCL_PATCH_LEVEL) == TCL_ERROR) {
return TCL_ERROR;
}
--- tcl86.orig/library/tm.tcl 2008-11-18 09:10:03.000000000 -0800
+++ tcl86/library/tm.tcl 2008-11-26 14:54:06.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 glob character-class
+ append res "\[$cu$cl\]"
+ }
+ }
+ }
+}
+
# Initialization. Set up the default paths, then insert the new
# handler into the chain.
--- tcl86.orig/tests/pkg.test 2008-11-18 09:10:01.000000000 -0800
+++ tcl86/tests/pkg.test 2008-11-24 12:11:22.000000000 -0800
@@ -572,10 +572,10 @@
} {}
test pkg-3.6 {Tcl_PackageCmd procedure, "ifneeded" option} {
list [catch {package ifneeded a} msg] $msg
-} {1 {wrong # args: should be "package ifneeded package version ?script?"}}
+} {1 {wrong # args: should be "package ifneeded ?-strict? package version ?script?"}}
test pkg-3.7 {Tcl_PackageCmd procedure, "ifneeded" option} {
list [catch {package ifneeded a b c d} msg] $msg
-} {1 {wrong # args: should be "package ifneeded package version ?script?"}}
+} {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"}}
@@ -629,10 +629,10 @@
} {x y}
test pkg-3.17 {Tcl_PackageCmd procedure, "provide" option} {
list [catch {package provide} msg] $msg
-} {1 {wrong # args: should be "package provide package ?version?"}}
+} {1 {wrong # args: should be "package provide ?-strict? package ?version?"}}
test pkg-3.18 {Tcl_PackageCmd procedure, "provide" option} {
list [catch {package provide a b c} msg] $msg
-} {1 {wrong # args: should be "package provide package ?version?"}}
+} {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
@@ -648,13 +648,13 @@
} {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 ?requirement ...?"}}
+} {1 {wrong # args: should be "package require ?-strict? ?-exact? package ?requirement ...?"}}
test pkg-3.24 {Tcl_PackageCmd procedure, "require" option} {
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 ...?"}}
+} {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
@@ -664,10 +664,10 @@
} {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 ?requirement ...?"}}
+} {1 {wrong # args: should be "package require ?-strict? ?-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 ?requirement ...?"}}
+} {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
@@ -714,10 +714,10 @@
} {0}
test pkg-3.42 {Tcl_PackageCmd procedure, "versions" option} {
list [catch {package versions} msg] $msg
-} {1 {wrong # args: should be "package versions package"}}
+} {1 {wrong # args: should be "package versions ?-strict? package"}}
test pkg-3.43 {Tcl_PackageCmd procedure, "versions" option} {
list [catch {package versions a b} msg] $msg
-} {1 {wrong # args: should be "package versions package"}}
+} {1 {wrong # args: should be "package versions ?-strict? package"}}
test pkg-3.44 {Tcl_PackageCmd procedure, "versions" option} {
package forget t
package versions t
@@ -888,13 +888,13 @@
} {1 {package t 2.4 is not present}}
test pkg-7.11 {Tcl_PackageCmd procedure, "present" option} {
list [catch {package present} msg] $msg
-} {1 {wrong # args: should be "package present ?-exact? package ?requirement ...?"}}
+} {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} {
list [catch {package present -exact a b c} msg] $msg
-} {1 {wrong # args: should be "package present ?-exact? package ?requirement ...?"}}
+} {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"}}
@@ -906,10 +906,10 @@
} {1 {expected version number but got "a.b"}}
test pkg-7.17 {Tcl_PackageCmd procedure, "present" option} {
list [catch {package present -exact x} msg] $msg
-} {1 {wrong # args: should be "package present ?-exact? package ?requirement ...?"}}
+} {1 {wrong # args: should be "package present ?-strict? ?-exact? package ?requirement ...?"}}
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 ?requirement ...?"}}
+} {1 {wrong # args: should be "package present ?-strict? ?-exact? package ?requirement ...?"}}
