summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog63
-rw-r--r--changes75
-rw-r--r--generic/tclBasic.c5
-rw-r--r--generic/tclExecute.c6
-rw-r--r--generic/tclIOCmd.c2
-rw-r--r--generic/tclInt.h31
-rw-r--r--generic/tclLink.c8
-rw-r--r--generic/tclListObj.c203
-rw-r--r--generic/tclLiteral.c71
-rwxr-xr-xgeneric/tclStrToD.c2
-rw-r--r--generic/tclStringObj.c19
-rw-r--r--generic/tclTrace.c10
-rw-r--r--generic/tclUtil.c25
-rw-r--r--library/tcltest/tcltest.tcl4
-rw-r--r--tests/fileSystem.test362
-rw-r--r--tests/init.test2
-rw-r--r--tests/namespace.test16
-rw-r--r--tests/package.test2
-rw-r--r--tests/socket.test4
19 files changed, 473 insertions, 437 deletions
diff --git a/ChangeLog b/ChangeLog
index f7b11cc..adabfbd 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,10 +1,71 @@
-2011-05-27 Reinhard Max <max@suse.de>
+2011-06-22 Reinhard Max <max@suse.de>
+ Merge from rmax-ipv6-branch:
* unix/tclUnixSock.c: Fix [socket -async], so that all addresses
returned by getaddrinfo() are tried, not just the first one. This
requires the event loop to be running while the async connection
is in progress. ***POTENTIAL INCOMPATIBILITY***
* tests/socket.test: Add a test for the above.
+ * doc/socket: Document the fact that -async needs the event loop
+ * generic/tclIOSock.c: AI_ADDRCONFIG is broken on HP-UX
+
+2011-06-21 Don Porter <dgp@users.sourceforge.net>
+
+ * generic/tclLink.c: Prevent multiple links to a single Tcl
+ variable when calling Tcl_LinkVar(). [Bug 3317466]
+
+2011-06-13 Don Porter <dgp@users.sourceforge.net>
+
+ * generic/tclStrToD.c: [Bug 3315098] Mem leak fix from Gustaf Neumann.
+
+2011-06-08 Andreas Kupries <andreask@activestate.com>
+
+ * generic/tclExecute.c: Reverted the fix for [Bug 3274728]
+ committed on 2011-04-06 and replaced with one which is
+ 64bit-safe. The existing fix crashed tclsh on Windows 64bit.
+
+2011-06-08 Donal K. Fellows <dkf@users.sf.net>
+
+ * tests/fileSystem.test: Reduce the amount of use of duplication of
+ complex code to perform common tests, and convert others to do the
+ test result check directly using Tcltest's own primitives.
+
+2011-06-06 Jan Nijtmans <nijtmans@users.sf.net>
+
+ * tests/socket.test: Add test constraint, so 6.2 and 6.3 don't fail
+ when the machine does not have support for ip6. Follow-up to checkin
+ from 2011-05-11 by rmax.
+
+2011-06-02 Don Porter <dgp@users.sourceforge.net>
+
+ * generic/tclBasic.c: Removed TclCleanupLiteralTable(), and old
+ * generic/tclInt.h: band-aid routine put in place while a fix
+ * generic/tclLiteral.c: for [Bug 994838] took shape. No longer needed.
+
+2011-06-02 Donal K. Fellows <dkf@users.sf.net>
+
+ * generic/tclInt.h (TclInvalidateNsCmdLookup): [Bug 3185407]: Extend
+ the set of epochs that are potentially bumped when a command is
+ created, for a slight performance drop (in some circumstances) and
+ improved semantics.
+
+2011-06-01 Miguel Sofer <msofer@users.sf.net>
+
+ * generic/tclBasic.c: Using the two free data elements in NRCommand to
+ store objc and objv - useful for debugging.
+
+2011-06-01 Jan Nijtmans <nijtmans@users.sf.net>
+
+ * generic/tclUtil.c: Fix for [Bug 3309871]: Valgrind finds:
+ invalid read in TclMaxListLength()
+
+2011-05-31 Don Porter <dgp@users.sourceforge.net>
+
+ * generic/tclInt.h: Use a complete growth algorithm for lists
+ * generic/tclListObj.c: so that length limits do not overconstrain
+ * generic/tclStringObj.c: by a factor of 2. [Bug 3293874]:
+ * generic/tclUtil.c: Fix includes rooting all growth routines
+ by default on a commone tunable parameter TCL_MIN_GROWTH.
2011-05-25 Don Porter <dgp@users.sourceforge.net>
diff --git a/changes b/changes
index 194e82a..144fd26 100644
--- a/changes
+++ b/changes
@@ -7867,4 +7867,77 @@ memory with buffer backup (ferrieux)
2010-11-09 (bug fix)[3105999] fixed memleak in OO var resolver (fellows)
---- Released 8.6b2, November 15, 2010 --- See ChangeLog for details ---
+2010-11-15 (TIP 378)[3081184] improved TIP 280 performance (kupries)
+
+2010-11-18 (bug fix)[3111059] leak in [namespace delete] w coroutines (sofer)
+
+2010-11-28 [3120139,3105247] Tcl_PrintDouble improvements (kenny)
+
+2010-11-29 (new cmd) [tcl::unsupported::inject] (ferrieux,sofer)
+
+2010-11-30 (enhancement) Restore TclFormatInt for performance (hobbs)
+
+2010-12-09 (new feature) [file] is now a [namespace ensemble] (fellows)
+
+2010-12-12 (platform) OpenBSD build improvements (cassoff)
+
+2010-12-17 (platform) Revisions to support rpm 4.4.2 (cassoff)
+
+2010-12-30 (bug fix)[3142026] GrowEvaluationStack OBOE (harder,sofer)
+
+2011-01-18 (bug fix)[3001438] [info frame -1] crash (mccormack,fellows)
+
+2011-03-01 (performance)[3168398] optimize [interp cancel] (mistachkin)
+
+2011-03-05 (bug fix)[3185009] crash in OO variables (danckaert,fellows)
+
+2011-03-05 (new cmd) [tcl::unsupported::assemble] (ugurlu,kenny)
+
+2011-03-06 (bug fix)[3200987,3192636] parser buffer overruns (porter)
+
+2011-03-08 (bug fix)[3202905] failed intrep release of interp result (mccormack)
+
+2011-03-09 (bug fix)[3202171] repair [namespace inscope] optimizer (porter)
+
+2011-03-10 (new version) better tcltest reporting from child interps (fellows)
+=> tcltest 2.3.3
+
+2011-03-10 (new feature) [namespace] is now a [namespace ensemble] (fellows)
+
+2011-03-12 (interface) reduce casting by ckalloc(), ckfree() callers (fellows)
+
+2011-03-14 (bug fix) Fixes from libtommath 0.42.0 release (fellows)
+
+2011-03-21 (bug fix)[3216070] [load] extension from embed Tcl apps (nijtmans)
+
+2011-03-27 (performance) NRE: LIST lset foreach benchmark (twylite)
+
+2011-04-11 (bug fix)[3282869] coroutine + eval + locals crash (ferrieux,sofer)
+
+2011-04-13 (bug fix)[2662380] crash when variable append trace unsets (sofer)
+
+2011-04-13 (bug fix)[3285375] Buffer overflow in [concat] (porter)
+
+2011-05-02 (internals change) revised TclFindElement() interface (porter)
+ *** POTENTIAL INCOMPATIBILITY ***
+
+2011-05-05 (enhancement) dict->list w/o string rep generation (porter)
+
+2011-05-10 (bug fix)[3173086] Crash parsing long lists (rogers,porter)
+
+2011-05-24 (enhancement) msgcat internal improvements (fellows)
+=> msgcat 1.4.4
+
+2011-05-24 tzdata updated to Olson's tzdata2011g (iyer)
+
+2011-05-25 (TIP 381) [info object|class call] [self call] [nextto] (fellows)
+
+2011-05-31 (bug fix)[3293874] let lists grow all the way to the limit (porter)
+
+2011-06-02 (bug fix)[3185407] cmd resolution epoch flaw (nadkarni,fellows)
+
+2011-06-13 (bug fix)[3315098] mem leak generating double string rep (neumann)
+
+Many more Tcl built-in command errors now set an -errorcode.
+
+--- Released 8.6b2, XXX XX, 2011 --- See ChangeLog for details ---
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index d80731e..6791cbf 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -1428,7 +1428,6 @@ DeleteInterpProc(
* table, as it will be freed later in this function without further use.
*/
- TclCleanupLiteralTable(interp, &iPtr->literalTable);
TclHandleFree(iPtr->handle);
TclTeardownNamespace(iPtr->globalNsPtr);
@@ -4140,10 +4139,10 @@ TclNREvalObjv(
*/
if (iPtr->evalFlags & TCL_EVAL_REDIRECT) {
- TclNRAddCallback(interp, NRCommand, NULL, INT2PTR(1), NULL, NULL);
+ TclNRAddCallback(interp, NRCommand, NULL, INT2PTR(1), objc, objv);
iPtr->evalFlags &= ~TCL_EVAL_REDIRECT;
} else {
- TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL);
+ TclNRAddCallback(interp, NRCommand, NULL, NULL, INT2PTR(objc), objv);
}
cmdPtrPtr = (Command **) &(TOP_CB(interp)->data[0]);
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 4fe65d7..84b0b63 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -172,7 +172,7 @@ typedef struct TEBCdata {
ByteCode *codePtr; /* Constant until the BC returns */
/* -----------------------------------------*/
const unsigned char *pc; /* These fields are used on return TO this */
- unsigned long *catchTop; /* this level: they record the state when a */
+ ptrdiff_t *catchTop; /* this level: they record the state when a */
int cleanup; /* new codePtr was received for NR */
Tcl_Obj *auxObjList; /* execution. */
int checkInterp;
@@ -1917,7 +1917,7 @@ TclIncrObj(
*----------------------------------------------------------------------
*/
#define bcFramePtr (&TD->cmdFrame)
-#define initCatchTop ((unsigned long *) (&TD->stack[-1]))
+#define initCatchTop ((ptrdiff_t *) (&TD->stack[-1]))
#define initTosPtr ((Tcl_Obj **) (initCatchTop+codePtr->maxExceptDepth))
#define esPtr (iPtr->execEnvPtr->execStackPtr)
@@ -6265,7 +6265,7 @@ TEBCresume(
while (auxObjList) {
if ((catchTop != initCatchTop) &&
- (*catchTop>auxObjList->internalRep.ptrAndLongRep.value)) {
+ (*catchTop > ((ptrdiff_t) auxObjList->internalRep.ptrAndLongRep.value))) {
break;
}
POP_TAUX_OBJ();
diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c
index 9294dd6..349814a 100644
--- a/generic/tclIOCmd.c
+++ b/generic/tclIOCmd.c
@@ -140,7 +140,7 @@ Tcl_PutsObjCmd(
string = objv[3];
break;
#if TCL_MAJOR_VERSION < 9
- } else if (strcmp(TclGetString(objv[2]), "nonewline") == 0) {
+ } else if (strcmp(TclGetString(objv[3]), "nonewline") == 0) {
/*
* The code below provides backwards compatibility with an old
* form of the command that is no longer recommended or
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 8f003be..ebc8bef 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2443,6 +2443,8 @@ typedef struct List {
#define LIST_MAX \
(1 + (int)(((size_t)UINT_MAX - sizeof(List))/sizeof(Tcl_Obj *)))
+#define LIST_SIZE(numElems) \
+ (unsigned)(sizeof(List) + (((numElems) - 1) * sizeof(Tcl_Obj *)))
/*
* Macro used to get the elements of a list object.
@@ -2891,8 +2893,6 @@ MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp,
MODULE_SCOPE Tcl_ObjCmdProc TclChannelNamesCmd;
MODULE_SCOPE int TclClearRootEnsemble(ClientData data[],
Tcl_Interp *interp, int result);
-MODULE_SCOPE void TclCleanupLiteralTable(Tcl_Interp *interp,
- LiteralTable *tablePtr);
MODULE_SCOPE ContLineLoc *TclContinuationsEnter(Tcl_Obj *objPtr, int num,
int *loc);
MODULE_SCOPE void TclContinuationsEnterDerived(Tcl_Obj *objPtr,
@@ -4097,8 +4097,22 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
*----------------------------------------------------------------
*/
+/* General tuning for minimum growth in Tcl growth algorithms */
+#ifndef TCL_MIN_GROWTH
+# ifdef TCL_GROWTH_MIN_ALLOC
+ /* Support for any legacy tuners */
+# define TCL_MIN_GROWTH TCL_GROWTH_MIN_ALLOC
+# else
+# define TCL_MIN_GROWTH 1024
+# endif
+#endif
+
+/* Token growth tuning, default to the general value. */
+#ifndef TCL_MIN_TOKEN_GROWTH
+#define TCL_MIN_TOKEN_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_Token)
+#endif
+
#define TCL_MAX_TOKENS (int)(UINT_MAX / sizeof(Tcl_Token))
-#define TCL_MIN_TOKEN_GROWTH 50
#define TclGrowTokenArray(tokenPtr, used, available, append, staticPtr) \
do { \
int needed = (used) + (append); \
@@ -4153,8 +4167,8 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
*/
#define TclUtfToUniChar(str, chPtr) \
- ((((unsigned char) *(str)) < 0xC0) ? \
- ((*(chPtr) = (Tcl_UniChar) *(str)), 1) \
+ ((((unsigned char) *(str)) < 0xC0) ? \
+ ((*(chPtr) = (Tcl_UniChar) *(str)), 1) \
: Tcl_UtfToUniChar(str, chPtr))
/*
@@ -4227,8 +4241,11 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
*/
#define TclInvalidateNsCmdLookup(nsPtr) \
- if ((nsPtr)->numExportPatterns) { \
- (nsPtr)->exportLookupEpoch++; \
+ if ((nsPtr)->numExportPatterns) { \
+ (nsPtr)->exportLookupEpoch++; \
+ } \
+ if ((nsPtr)->commandPathLength) { \
+ (nsPtr)->cmdRefEpoch++; \
}
/*
diff --git a/generic/tclLink.c b/generic/tclLink.c
index 00010f3..a3b42bd 100644
--- a/generic/tclLink.c
+++ b/generic/tclLink.c
@@ -112,6 +112,14 @@ Tcl_LinkVar(
Link *linkPtr;
int code;
+ linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY,
+ LinkTraceProc, (ClientData) NULL);
+ if (linkPtr != NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "variable '%s' is already linked", varName));
+ return TCL_ERROR;
+ }
+
linkPtr = ckalloc(sizeof(Link));
linkPtr->interp = interp;
linkPtr->varName = Tcl_NewStringObj(varName, -1);
diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index 506aa54..ac87628 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -45,6 +45,11 @@ const Tcl_ObjType tclListType = {
UpdateStringOfList, /* updateStringProc */
SetListFromAny /* setFromAnyProc */
};
+
+#ifndef TCL_MIN_ELEMENT_GROWTH
+#define TCL_MIN_ELEMENT_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_Obj *)
+#endif
+
/*
*----------------------------------------------------------------------
@@ -96,11 +101,11 @@ NewListIntRep(
return NULL;
}
- listRepPtr = attemptckalloc(sizeof(List) + ((objc-1) * sizeof(Tcl_Obj*)));
+ listRepPtr = attemptckalloc(LIST_SIZE(objc));
if (listRepPtr == NULL) {
if (p) {
Tcl_Panic("list creation failed: unable to alloc %u bytes",
- (unsigned)(sizeof(List) + ((objc-1) * sizeof(Tcl_Obj *))));
+ LIST_SIZE(objc));
}
return NULL;
}
@@ -163,7 +168,7 @@ AttemptNewList(
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"list creation failed: unable to alloc %u bytes",
- (unsigned)(sizeof(List) + ((objc-1) * sizeof(Tcl_Obj *)))));
+ LIST_SIZE(objc)));
}
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
}
@@ -482,16 +487,13 @@ Tcl_ListObjGetElements(
*
* Tcl_ListObjAppendList --
*
- * This function appends the objects in the list referenced by
- * elemListPtr to the list object referenced by listPtr. If listPtr is
- * not already a list object, an attempt will be made to convert it to
- * one.
+ * This function appends the elements in the list value referenced by
+ * elemListPtr to the list value referenced by listPtr.
*
* Results:
* The return value is normally TCL_OK. If listPtr or elemListPtr do not
- * refer to list objects and they can not be converted to one, TCL_ERROR
- * is returned and an error message is left in the interpreter's result
- * if interp is not NULL.
+ * refer to list values, TCL_ERROR is returned and an error message is
+ * left in the interpreter's result if interp is not NULL.
*
* Side effects:
* The reference counts of the elements in elemListPtr are incremented
@@ -509,29 +511,24 @@ Tcl_ListObjAppendList(
register Tcl_Obj *listPtr, /* List object to append elements to. */
Tcl_Obj *elemListPtr) /* List obj with elements to append. */
{
- int listLen, objc, result;
+ int objc;
Tcl_Obj **objv;
if (Tcl_IsShared(listPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendList");
}
- result = TclListObjLength(interp, listPtr, &listLen);
- if (result != TCL_OK) {
- return result;
- }
-
- result = TclListObjGetElements(interp, elemListPtr, &objc, &objv);
- if (result != TCL_OK) {
- return result;
+ /* Pull the elements to append from elemListPtr */
+ if (TCL_OK != TclListObjGetElements(interp, elemListPtr, &objc, &objv)) {
+ return TCL_ERROR;
}
/*
- * Insert objc new elements starting after the lists's last element.
+ * Insert the new elements starting after the lists's last element.
* Delete zero existing elements.
*/
- return Tcl_ListObjReplace(interp, listPtr, listLen, 0, objc, objv);
+ return Tcl_ListObjReplace(interp, listPtr, LIST_MAX, 0, objc, objv);
}
/*
@@ -567,9 +564,8 @@ Tcl_ListObjAppendElement(
Tcl_Obj *listPtr, /* List object to append objPtr to. */
Tcl_Obj *objPtr) /* Object to append to listPtr's list. */
{
- register List *listRepPtr;
- register Tcl_Obj **elemPtrs;
- int numElems, numRequired, newMax, newSize, i;
+ register List *listRepPtr, *newPtr = NULL;
+ int numElems, numRequired, needGrow, isShared, attempt;
if (Tcl_IsShared(listPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendElement");
@@ -590,41 +586,90 @@ Tcl_ListObjAppendElement(
listRepPtr = ListRepPtr(listPtr);
numElems = listRepPtr->elemCount;
numRequired = numElems + 1 ;
+ needGrow = (numRequired > listRepPtr->maxElemCount);
+ isShared = (listRepPtr->refCount > 1);
- /*
- * If there is no room in the current array of element pointers, allocate
- * a new, larger array and copy the pointers to it. If the List struct is
- * shared, allocate a new one.
- */
-
- if (numRequired > listRepPtr->maxElemCount){
- newMax = 2 * numRequired;
- newSize = sizeof(List) + ((newMax-1) * sizeof(Tcl_Obj *));
- } else {
- newMax = listRepPtr->maxElemCount;
- newSize = 0;
+ if (numRequired > LIST_MAX) {
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "max length of a Tcl list (%d elements) exceeded",
+ LIST_MAX));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ }
+ return TCL_ERROR;
}
- if (listRepPtr->refCount > 1) {
- List *oldListRepPtr = listRepPtr;
- Tcl_Obj **oldElems;
+ if (needGrow && !isShared) {
+ /* Need to grow + unshared intrep => try to realloc */
+ attempt = 2 * numRequired;
+ if (attempt <= LIST_MAX) {
+ newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
+ }
+ if (newPtr == NULL) {
+ attempt = numRequired + 1 + TCL_MIN_ELEMENT_GROWTH;
+ if (attempt > LIST_MAX) {
+ attempt = LIST_MAX;
+ }
+ newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
+ }
+ if (newPtr == NULL) {
+ attempt = numRequired;
+ newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
+ }
+ if (newPtr) {
+ listRepPtr = newPtr;
+ listRepPtr->maxElemCount = attempt;
+ needGrow = 0;
+ }
+ }
+ if (isShared || needGrow) {
+ Tcl_Obj **dst, **src = &listRepPtr->elements;
- listRepPtr = AttemptNewList(interp, newMax, NULL);
- if (listRepPtr == NULL) {
+ /*
+ * Either we have a shared intrep and we must copy to write,
+ * or we need to grow and realloc attempts failed.
+ * Attempt intrep copy.
+ */
+ attempt = 2 * numRequired;
+ newPtr = AttemptNewList(NULL, attempt, NULL);
+ if (newPtr == NULL) {
+ attempt = numRequired + 1 + TCL_MIN_ELEMENT_GROWTH;
+ if (attempt > LIST_MAX) {
+ attempt = LIST_MAX;
+ }
+ newPtr = AttemptNewList(NULL, attempt, NULL);
+ }
+ if (newPtr == NULL) {
+ attempt = numRequired;
+ newPtr = AttemptNewList(interp, attempt, NULL);
+ }
+ if (newPtr == NULL) {
+ /* All growth attempts failed; throw the error */
return TCL_ERROR;
}
- oldElems = &oldListRepPtr->elements;
- elemPtrs = &listRepPtr->elements;
- for (i=0; i<numElems; i++) {
- elemPtrs[i] = oldElems[i];
- Tcl_IncrRefCount(elemPtrs[i]);
+
+ dst = &newPtr->elements;
+ newPtr->refCount++;
+ newPtr->canonicalFlag = listRepPtr->canonicalFlag;
+ newPtr->elemCount = listRepPtr->elemCount;
+
+ if (isShared) {
+ /*
+ * The original intrep must remain undisturbed.
+ * Copy into the new one and bump refcounts
+ */
+ while (numElems--) {
+ *dst = *src++;
+ Tcl_IncrRefCount(*dst++);
+ }
+ listRepPtr->refCount--;
+ } else {
+ /* Old intrep to be freed, re-use refCounts */
+ memcpy(dst, src, (size_t) numElems * sizeof(Tcl_Obj *));
+
+ ckfree(listRepPtr);
}
- listRepPtr->elemCount = numElems;
- listRepPtr->refCount++;
- oldListRepPtr->refCount--;
- } else if (newSize) {
- listRepPtr = ckrealloc(listRepPtr, newSize);
- listRepPtr->maxElemCount = newMax;
+ listRepPtr = newPtr;
}
listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr;
@@ -633,8 +678,7 @@ Tcl_ListObjAppendElement(
* the ref count for the (now shared) objPtr.
*/
- elemPtrs = &listRepPtr->elements;
- elemPtrs[numElems] = objPtr;
+ *(&listRepPtr->elements + listRepPtr->elemCount) = objPtr;
Tcl_IncrRefCount(objPtr);
listRepPtr->elemCount++;
@@ -898,9 +942,20 @@ Tcl_ListObjReplace(
newMax = listRepPtr->maxElemCount;
}
- listRepPtr = AttemptNewList(interp, newMax, NULL);
+ listRepPtr = AttemptNewList(NULL, newMax, NULL);
if (listRepPtr == NULL) {
- return TCL_ERROR;
+ unsigned int limit = LIST_MAX - numRequired;
+ unsigned int extra = numRequired - numElems
+ + TCL_MIN_ELEMENT_GROWTH;
+ int growth = (int) ((extra > limit) ? limit : extra);
+
+ listRepPtr = AttemptNewList(NULL, numRequired + growth, NULL);
+ if (listRepPtr == NULL) {
+ listRepPtr = AttemptNewList(interp, numRequired, NULL);
+ if (listRepPtr == NULL) {
+ return TCL_ERROR;
+ }
+ }
}
listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr;
@@ -1544,7 +1599,6 @@ TclListObjSetElement(
listRepPtr = ListRepPtr(listPtr);
elemCount = listRepPtr->elemCount;
- elemPtrs = &listRepPtr->elements;
/*
* Ensure that the index is in bounds.
@@ -1565,25 +1619,30 @@ TclListObjSetElement(
*/
if (listRepPtr->refCount > 1) {
- List *oldListRepPtr = listRepPtr;
- Tcl_Obj **oldElemPtrs = elemPtrs;
- int i;
+ Tcl_Obj **dst, **src = &listRepPtr->elements;
+ List *newPtr = AttemptNewList(NULL, listRepPtr->maxElemCount, NULL);
- listRepPtr = AttemptNewList(interp, listRepPtr->maxElemCount, NULL);
- if (listRepPtr == NULL) {
- return TCL_ERROR;
+ if (newPtr == NULL) {
+ newPtr = AttemptNewList(interp, elemCount, NULL);
+ if (newPtr == NULL) {
+ return TCL_ERROR;
+ }
}
- listRepPtr->canonicalFlag = oldListRepPtr->canonicalFlag;
- elemPtrs = &listRepPtr->elements;
- for (i=0; i < elemCount; i++) {
- elemPtrs[i] = oldElemPtrs[i];
- Tcl_IncrRefCount(elemPtrs[i]);
+ newPtr->refCount++;
+ newPtr->elemCount = elemCount;
+ newPtr->canonicalFlag = listRepPtr->canonicalFlag;
+
+ dst = &newPtr->elements;
+ while (elemCount--) {
+ *dst = *src++;
+ Tcl_IncrRefCount(*dst++);
}
- listRepPtr->refCount++;
- listRepPtr->elemCount = elemCount;
- listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr;
- oldListRepPtr->refCount--;
+
+ listRepPtr->refCount--;
+
+ listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr = newPtr;
}
+ elemPtrs = &listRepPtr->elements;
/*
* Add a reference to the new list element.
diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c
index 72c4577..3a9f8e1 100644
--- a/generic/tclLiteral.c
+++ b/generic/tclLiteral.c
@@ -75,77 +75,6 @@ TclInitLiteralTable(
/*
*----------------------------------------------------------------------
*
- * TclCleanupLiteralTable --
- *
- * This function frees the internal representation of every literal in a
- * literal table. It is called prior to deleting an interp, so that
- * variable refs will be cleaned up properly.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Each literal in the table has its internal representation freed.
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclCleanupLiteralTable(
- Tcl_Interp *interp, /* Interpreter containing literals to purge */
- LiteralTable *tablePtr) /* Points to the literal table being
- * cleaned. */
-{
- int i;
- LiteralEntry *entryPtr; /* Pointer to the current entry in the hash
- * table of literals. */
- LiteralEntry *nextPtr; /* Pointer to the next entry in the bucket. */
- Tcl_Obj *objPtr; /* Pointer to a literal object whose internal
- * rep is being freed. */
- const Tcl_ObjType *typePtr; /* Pointer to the object's type. */
- int didOne; /* Flag for whether we've removed a literal in
- * the current bucket. */
-
-#ifdef TCL_COMPILE_DEBUG
- TclVerifyGlobalLiteralTable((Interp *) interp);
-#endif /* TCL_COMPILE_DEBUG */
-
- for (i=0 ; i<tablePtr->numBuckets ; i++) {
- /*
- * It is tempting simply to walk each hash bucket once and delete the
- * internal representations of each literal in turn. It's also wrong.
- * The problem is that freeing a literal's internal representation can
- * delete other literals to which it refers, making nextPtr invalid.
- * So each time we free an internal rep, we start its bucket over
- * again.
- */
-
- do {
- didOne = 0;
- entryPtr = tablePtr->buckets[i];
- while (entryPtr != NULL) {
- objPtr = entryPtr->objPtr;
- nextPtr = entryPtr->nextPtr;
- typePtr = objPtr->typePtr;
- if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
- if (objPtr->bytes == NULL) {
- Tcl_Panic("%s: literal without a string rep",
- "TclCleanupLiteralTable");
- }
- objPtr->typePtr = NULL;
- typePtr->freeIntRepProc(objPtr);
- didOne = 1;
- break;
- }
- entryPtr = nextPtr;
- }
- } while (didOne);
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
* TclDeleteLiteralTable --
*
* This function frees up everything associated with a literal table
diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c
index 59192e9..16f11d2 100755
--- a/generic/tclStrToD.c
+++ b/generic/tclStrToD.c
@@ -3820,7 +3820,7 @@ ShorteningBignumConversion(
if (m2plus > m2minus) {
mp_clear(&mplus);
}
- mp_clear_multi(&b, &mminus, &temp, NULL);
+ mp_clear_multi(&b, &mminus, &temp, &dig, &S, NULL);
*s = '\0';
*decpt = k;
if (endPtr) {
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 0f6eff7..ab62359 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -152,8 +152,7 @@ typedef struct String {
*
* Attempt to allocate 2 * (originalLength + appendLength)
* On failure:
- * attempt to allocate originalLength + 2*appendLength +
- * TCL_GROWTH_MIN_ALLOC
+ * attempt to allocate originalLength + 2*appendLength + TCL_MIN_GROWTH
*
* This algorithm allows very good performance, as it rapidly increases the
* memory allocated for a given string, which minimizes the number of
@@ -166,20 +165,20 @@ typedef struct String {
* cover the request, but which hopefully will be less than the total
* available memory.
*
- * The addition of TCL_GROWTH_MIN_ALLOC allows for efficient handling of very
+ * The addition of TCL_MIN_GROWTH allows for efficient handling of very
* small appends. Without this extra slush factor, a sequence of several small
* appends would cause several memory allocations. As long as
- * TCL_GROWTH_MIN_ALLOC is a reasonable size, we can avoid that behavior.
+ * TCL_MIN_GROWTH is a reasonable size, we can avoid that behavior.
*
* The growth algorithm can be tuned by adjusting the following parameters:
*
- * TCL_GROWTH_MIN_ALLOC Additional space, in bytes, to allocate when
+ * TCL_MIN_GROWTH Additional space, in bytes, to allocate when
* the double allocation has failed. Default is
- * 1024 (1 kilobyte).
+ * 1024 (1 kilobyte). See tclInt.h.
*/
-#ifndef TCL_GROWTH_MIN_ALLOC
-#define TCL_GROWTH_MIN_ALLOC 1024
+#ifndef TCL_MIN_UNICHAR_GROWTH
+#define TCL_MIN_UNICHAR_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_UniChar)
#endif
static void
@@ -214,7 +213,7 @@ GrowStringBuffer(
*/
unsigned int limit = INT_MAX - needed;
- unsigned int extra = needed - objPtr->length + TCL_GROWTH_MIN_ALLOC;
+ unsigned int extra = needed - objPtr->length + TCL_MIN_GROWTH;
int growth = (int) ((extra > limit) ? limit : extra);
attempt = needed + growth;
@@ -265,7 +264,7 @@ GrowUnicodeBuffer(
unsigned int limit = STRING_MAXCHARS - needed;
unsigned int extra = needed - stringPtr->numChars
- + TCL_GROWTH_MIN_ALLOC/sizeof(Tcl_UniChar);
+ + TCL_MIN_UNICHAR_GROWTH;
int growth = (int) ((extra > limit) ? limit : extra);
attempt = needed + growth;
diff --git a/generic/tclTrace.c b/generic/tclTrace.c
index a60a80b..13359ee 100644
--- a/generic/tclTrace.c
+++ b/generic/tclTrace.c
@@ -2883,6 +2883,16 @@ Tcl_UntraceVar2(
* The code below makes it possible to delete traces while traces are
* active: it makes sure that the deleted trace won't be processed by
* TclCallVarTraces.
+ *
+ * Caveat (Bug 3062331): When an unset trace handler on a variable
+ * tries to delete a different unset trace handler on the same variable,
+ * the results may be surprising. When variable unset traces fire, the
+ * traced variable is already gone. So the TclLookupVar() call above
+ * will not find that variable, and not finding it will never reach here
+ * to perform the deletion. This means callers of Tcl_UntraceVar*()
+ * attempting to delete unset traces from within the handler of another
+ * unset trace have to account for the possibility that their call to
+ * Tcl_UntraceVar*() is a no-op.
*/
for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL;
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index f7f4bf4..6f36dad 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -409,7 +409,7 @@ TclMaxListLength(
bytes++;
numBytes -= (numBytes != -1);
} while (numBytes && TclIsSpaceProc(*bytes));
- if (numBytes == 0) {
+ if ((numBytes == 0) || ((numBytes == -1) && (*bytes == '\0'))) {
break;
}
/* (*bytes) is non-space; return to counting state */
@@ -1778,31 +1778,16 @@ Tcl_ConcatObj(
}
}
if (i == objc) {
- Tcl_Obj **listv;
- int listc;
-
resPtr = NULL;
for (i = 0; i < objc; i++) {
- /*
- * Tcl_ListObjAppendList could be used here, but this saves us a
- * bit of type checking (since we've already done it). Use of
- * INT_MAX tells us to always put the new stuff on the end. It
- * will be set right in Tcl_ListObjReplace.
- * Note that all objs at this point are either lists or have an
- * empty string rep.
- */
-
objPtr = objv[i];
if (objPtr->bytes && objPtr->length == 0) {
continue;
}
- TclListObjGetElements(NULL, objPtr, &listc, &listv);
- if (listc) {
- if (resPtr) {
- Tcl_ListObjReplace(NULL, resPtr, INT_MAX, 0, listc, listv);
- } else {
- resPtr = TclListObjCopy(NULL, objPtr);
- }
+ if (resPtr) {
+ Tcl_ListObjAppendList(NULL, resPtr, objPtr);
+ } else {
+ resPtr = TclListObjCopy(NULL, objPtr);
}
}
if (!resPtr) {
diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl
index ad61f9c..af809f6 100644
--- a/library/tcltest/tcltest.tcl
+++ b/library/tcltest/tcltest.tcl
@@ -797,8 +797,8 @@ namespace eval tcltest {
proc loadIntoSlaveInterpreter {slave args} {
variable Version
- interp eval $slave [list set ::argv $args]
- interp eval $slave [list package require tcltest $Version]
+ interp eval $slave [package ifneeded tcltest $Version]
+ interp eval $slave "tcltest::configure {*}{$args}"
interp alias $slave ::tcltest::ReportToMaster \
{} ::tcltest::ReportedFromSlave
}
diff --git a/tests/fileSystem.test b/tests/fileSystem.test
index 6ab554b..4191713 100644
--- a/tests/fileSystem.test
+++ b/tests/fileSystem.test
@@ -31,44 +31,39 @@ makeDirectory [file join dir.dir dirinside.dir]
makeFile "test file in directory" [file join dir.dir inside.file]
testConstraint unusedDrive 0
-set drive {}
-if {[testConstraint win]} {
- set vols [string map [list :/ {}] [file volumes]]
- for {set i 0} {$i < 26} {incr i} {
- set drive [format %c [expr {$i + 65}]]
- if {$drive ni $vols} {
- testConstraint unusedDrive 1
- break
+testConstraint moreThanOneDrive 0
+apply {{} {
+ # The variables 'drive' and 'drives' will be used below.
+ variable drive {} drives {}
+ if {[testConstraint win]} {
+ set vols [string map [list :/ {}] [file volumes]]
+ for {set i 0} {$i < 26} {incr i} {
+ set drive [format %c [expr {$i + 65}]]
+ if {$drive ni $vols} {
+ testConstraint unusedDrive 1
+ break
+ }
}
- }
- unset i vols
- # The variable 'drive' will be used below
-}
-testConstraint moreThanOneDrive 0
-set drives [list]
-if {[testConstraint win]} {
- set dir [pwd]
- foreach vol [file volumes] {
- if {![catch {cd $vol}]} {
- lappend drives $vol
- }
- }
- if {[llength $drives] > 1} {
- testConstraint moreThanOneDrive 1
+ set dir [pwd]
+ try {
+ foreach vol [file volumes] {
+ if {![catch {cd $vol}]} {
+ lappend drives $vol
+ }
+ }
+ testConstraint moreThanOneDrive [llength $drives]
+ } finally {
+ cd $dir
+ }
}
- # The variable 'drives' will be used below
- unset vol
- cd $dir
- unset dir
-}
+} ::tcl::test::fileSystem}
proc testPathEqual {one two} {
if {$one eq $two} {
- return 1
- } else {
- return "not equal: $one $two"
+ return "ok"
}
+ return "not equal: $one $two"
}
testConstraint hasLinks [expr {![catch {
@@ -100,19 +95,19 @@ test filesystem-1.1 {link normalisation} {hasLinks} {
test filesystem-1.2 {link normalisation} {hasLinks unix} {
testPathEqual [file normalize [file join gorp.file foo]] \
[file normalize [file join link.file foo]]
-} {1}
+} ok
test filesystem-1.3 {link normalisation} {hasLinks} {
testPathEqual [file normalize [file join dir.dir foo]] \
[file normalize [file join dir.link foo]]
-} {1}
+} ok
test filesystem-1.4 {link normalisation} {hasLinks} {
testPathEqual [file normalize [file join dir.dir inside.file]] \
[file normalize [file join dir.link inside.file]]
-} {1}
+} ok
test filesystem-1.5 {link normalisation} {hasLinks} {
testPathEqual [file normalize [file join dir.dir linkinside.file]] \
[file normalize [file join dir.dir linkinside.file]]
-} {1}
+} ok
test filesystem-1.6 {link normalisation} {hasLinks} {
string equal [file normalize [file join dir.dir linkinside.file]] \
[file normalize [file join dir.link inside.file]]
@@ -120,28 +115,29 @@ test filesystem-1.6 {link normalisation} {hasLinks} {
test filesystem-1.7 {link normalisation} {hasLinks unix} {
testPathEqual [file normalize [file join dir.link linkinside.file foo]] \
[file normalize [file join dir.dir inside.file foo]]
-} {1}
+} ok
test filesystem-1.8 {link normalisation} {hasLinks} {
string equal [file normalize [file join dir.dir linkinside.filefoo]] \
[file normalize [file join dir.link inside.filefoo]]
} {0}
-test filesystem-1.9 {link normalisation} {unix hasLinks} {
+test filesystem-1.9 {link normalisation} -setup {
file delete -force dir.link
+} -constraints {unix hasLinks} -body {
file link dir.link [file nativename dir.dir]
testPathEqual [file normalize [file join dir.dir linkinside.file foo]] \
[file normalize [file join dir.link inside.file foo]]
-} {1}
+} -result ok
test filesystem-1.10 {link normalisation: double link} {unix hasLinks} {
file link dir2.link dir.link
testPathEqual [file normalize [file join dir.dir linkinside.file foo]] \
[file normalize [file join dir2.link inside.file foo]]
-} {1}
+} ok
makeDirectory dir2.file
test filesystem-1.11 {link normalisation: double link, back in tree} {unix hasLinks} {
file link [file join dir2.file dir2.link] [file join .. dir2.link]
testPathEqual [file normalize [file join dir.dir linkinside.file foo]] \
[file normalize [file join dir2.file dir2.link inside.file foo]]
-} {1}
+} ok
test filesystem-1.12 {file new native path} {} {
for {set i 0} {$i < 10} {incr i} {
foreach f [lsort [glob -nocomplain -type l *]] {
@@ -198,39 +194,35 @@ test filesystem-1.25 {file normalisation} {win unusedDrive} {
test filesystem-1.25.1 {file normalisation} {win unusedDrive} {
file normalize ${drive}:/./.././..\\..\\a\\bb
} "${drive}:/a/bb"
-test filesystem-1.26 {link normalisation: link and ..} {hasLinks} {
+test filesystem-1.26 {link normalisation: link and ..} -setup {
file delete -force dir2.link
+} -constraints {hasLinks} -body {
set dir [file join dir2 foo bar]
file mkdir $dir
file link dir2.link [file join dir2 foo bar]
- set res [list [file normalize [file join dir2 foo x]] \
- [file normalize [file join dir2.link .. x]]]
- testPathEqual [lindex $res 0] [lindex $res 1]
-} 1
+ testPathEqual [file normalize [file join dir2 foo x]] \
+ [file normalize [file join dir2.link .. x]]
+} -result ok
test filesystem-1.27 {file normalisation: up and down with ..} {
set dir [file join dir2 foo bar]
file mkdir $dir
set dir2 [file join dir2 .. dir2 foo .. foo bar]
- set res [list [file normalize $dir] [file normalize $dir2]]
- set res2 [list [file exists $dir] [file exists $dir2]]
- if {![string equal [lindex $res 0] [lindex $res 1]]} {
- set res "exists: $res2, $res not equal"
- } else {
- set res "ok: $res2"
- }
-} {ok: 1 1}
-test filesystem-1.28 {link normalisation: link with .. and ..} {hasLinks} {
+ list [testPathEqual [file normalize $dir] [file normalize $dir2]] \
+ [file exists $dir] [file exists $dir2]
+} {ok 1 1}
+test filesystem-1.28 {link normalisation: link with .. and ..} -setup {
file delete -force dir2.link
+} -constraints {hasLinks} -body {
set dir [file join dir2 foo bar]
file mkdir $dir
set to [file join dir2 .. dir2 foo .. foo bar]
file link dir2.link $to
- set res [list [file normalize [file join dir2 foo x]] \
- [file normalize [file join dir2.link .. x]]]
- testPathEqual [lindex $res 0] [lindex $res 1]
-} 1
-test filesystem-1.29 {link normalisation: link with ..} {hasLinks} {
+ testPathEqual [file normalize [file join dir2 foo x]] \
+ [file normalize [file join dir2.link .. x]]
+} -result ok
+test filesystem-1.29 {link normalisation: link with ..} -setup {
file delete -force dir2.link
+} -constraints {hasLinks} -body {
set dir [file join dir2 foo bar]
file mkdir $dir
set to [file join dir2 .. dir2 foo .. foo bar]
@@ -240,11 +232,11 @@ test filesystem-1.29 {link normalisation: link with ..} {hasLinks} {
return "$res must not contain '..'"
}
return "ok"
-} {ok}
+} -result {ok}
test filesystem-1.29.1 {link normalisation with two consecutive links} {hasLinks} {
testPathEqual [file normalize [file join dir.link dirinside.link abc]] \
[file normalize [file join dir.dir dirinside.dir abc]]
-} {1}
+} ok
file delete -force dir2.file
file delete -force dir2.link
file delete -force link.file dir.link
@@ -277,208 +269,96 @@ test filesystem-1.33 {link normalisation: link near filesystem root} {testsetpla
if {[testConstraint testsetplatform]} {
testsetplatform $platform
}
-test filesystem-1.34 {file normalisation with '/./'} {
- set res [file normalize /foo/bar/anc/./.tml]
- if {[string first "/./" $res] != -1} {
- set res "normalization of /foo/bar/anc/./.tml is: $res"
- } else {
- set res "ok"
- }
- set res
-} {ok}
-test filesystem-1.35 {file normalisation with '/./'} {
- set res [file normalize /ffo/bar/anc/./foo/.tml]
- if {[string first "/./" $res] != -1 || ([regsub -all "foo" $res "" reg] == 2)} {
- set res "normalization of /ffo/bar/anc/./foo/.tml is: $res"
- } else {
- set res "ok"
- }
- set res
-} {ok}
-test filesystem-1.36 {file normalisation with '/./'} {
- set res [file normalize /foo/bar/anc/././asdasd/.tml]
- if {[string first "/./" $res] != -1 || ([regsub -all "asdasd" $res "" reg] == 2) } {
- set res "normalization of /foo/bar/anc/././asdasd/.tml is: $res"
- } else {
- set res "ok"
- }
- set res
-} {ok}
-test filesystem-1.37 {file normalisation with '/./'} {
+test filesystem-1.34 {file normalisation with '/./'} -body {
+ file normalize /foo/bar/anc/./.tml
+} -match regexp -result {^(?:(?!/\./).)*$}
+test filesystem-1.35a {file normalisation with '/./'} -body {
+ file normalize /ffo/bar/anc/./foo/.tml
+} -match regexp -result {^(?:(?!/\./).)*$}
+test filesystem-1.35b {file normalisation with '/./'} {
+ llength [regexp -all foo [file normalize /ffo/bar/anc/./foo/.tml]]
+} 1
+test filesystem-1.36a {file normalisation with '/./'} -body {
+ file normalize /foo/bar/anc/././asdasd/.tml
+} -match regexp -result {^(?:(?!/\./).)*$}
+test filesystem-1.36b {file normalisation with '/./'} {
+ llength [regexp -all asdasd [file normalize /foo/bar/anc/././asdasd/.tml]]
+} 1
+test filesystem-1.37 {file normalisation with '/./'} -body {
set fname "/abc/./def/./ghi/./asda/.././.././asd/x/../../../../....."
- set res [file norm $fname]
- if {[string first "//" $res] != -1} {
- set res "normalization of $fname is: $res"
- } else {
- set res "ok"
- }
- set res
-} {ok}
-test filesystem-1.38 {file normalisation with volume relative} \
- {win moreThanOneDrive} {
- set path "[string range [lindex $drives 0] 0 1]foo"
+ file norm $fname
+} -match regexp -result {^(?:[^/]|/(?:[^/]|$))+$}
+test filesystem-1.38 {file normalisation with volume relative} -setup {
set dir [pwd]
+} -constraints {win moreThanOneDrive} -body {
+ set path "[string range [lindex $drives 0] 0 1]foo"
cd [lindex $drives 1]
- set res [file norm $path]
+ file norm $path
+} -cleanup {
cd $dir
- set res
-} "[lindex $drives 0]foo"
-test filesystem-1.39 {file normalisation with volume relative} {win} {
- set drv C:/
- set dir [lindex [glob -type d -dir $drv *] 0]
+} -result "[lindex $drives 0]foo"
+test filesystem-1.39 {file normalisation with volume relative} -setup {
set old [pwd]
- cd $dir
- set res [file norm [string range $drv 0 1]]
+} -constraints {win} -body {
+ set drv C:/
+ cd [lindex [glob -type d -dir $drv *] 0]
+ file norm [string range $drv 0 1]
+} -cleanup {
cd $old
- if {[string index $res end] eq "/"} {
- set res "Bad normalized path: $res"
- } else {
- set res "ok"
- }
-} {ok}
+} -match glob -result {*[^/]}
test filesystem-1.40 {file normalisation with repeated separators} {
- set a [file norm foo////bar]
- set b [file norm foo/bar]
- if {![string equal $a $b]} {
- set res "Paths should be equal: $a , $b"
- } else {
- set res "ok"
- }
-} {ok}
+ testPathEqual [file norm foo////bar] [file norm foo/bar]
+} ok
test filesystem-1.41 {file normalisation with repeated separators} {win} {
- set a [file norm foo\\\\\\bar]
- set b [file norm foo/bar]
- if {![string equal $a $b]} {
- set res "Paths should be equal: $a , $b"
- } else {
- set res "ok"
- }
-} {ok}
+ testPathEqual [file norm foo\\\\\\bar] [file norm foo/bar]
+} ok
test filesystem-1.42 {file normalisation .. beyond root (Bug 1379287)} {
- set a [file norm /xxx/..]
- set b [file norm /]
- if {![string equal $a $b]} {
- set res "Paths should be equal: $a , $b"
- } else {
- set res "ok"
- }
-} {ok}
+ testPathEqual [file norm /xxx/..] [file norm /]
+} ok
test filesystem-1.42.1 {file normalisation .. beyond root (Bug 1379287)} {
- set a [file norm /xxx/../]
- set b [file norm /]
- if {![string equal $a $b]} {
- set res "Paths should be equal: $a , $b"
- } else {
- set res "ok"
- }
-} {ok}
+ testPathEqual [file norm /xxx/../] [file norm /]
+} ok
test filesystem-1.43 {file normalisation .. beyond root (Bug 1379287)} {
- set a [file norm /xxx/foo/../..]
- set b [file norm /]
- if {![string equal $a $b]} {
- set res "Paths should be equal: $a , $b"
- } else {
- set res "ok"
- }
-} {ok}
+ testPathEqual [file norm /xxx/foo/../..] [file norm /]
+} ok
test filesystem-1.43.1 {file normalisation .. beyond root (Bug 1379287)} {
- set a [file norm /xxx/foo/../../]
- set b [file norm /]
- if {![string equal $a $b]} {
- set res "Paths should be equal: $a , $b"
- } else {
- set res "ok"
- }
-} {ok}
+ testPathEqual [file norm /xxx/foo/../../] [file norm /]
+} ok
test filesystem-1.44 {file normalisation .. beyond root (Bug 1379287)} {
- set a [file norm /xxx/foo/../../bar]
- set b [file norm /bar]
- if {![string equal $a $b]} {
- set res "Paths should be equal: $a , $b"
- } else {
- set res "ok"
- }
-} {ok}
+ testPathEqual [file norm /xxx/foo/../../bar] [file norm /bar]
+} ok
test filesystem-1.45 {file normalisation .. beyond root (Bug 1379287)} {
- set a [file norm /xxx/../../bar]
- set b [file norm /bar]
- if {![string equal $a $b]} {
- set res "Paths should be equal: $a , $b"
- } else {
- set res "ok"
- }
-} {ok}
+ testPathEqual [file norm /xxx/../../bar] [file norm /bar]
+} ok
test filesystem-1.46 {file normalisation .. beyond root (Bug 1379287)} {
- set a [file norm /xxx/../bar]
- set b [file norm /bar]
- if {![string equal $a $b]} {
- set res "Paths should be equal: $a , $b"
- } else {
- set res "ok"
- }
-} {ok}
+ testPathEqual [file norm /xxx/../bar] [file norm /bar]
+} ok
test filesystem-1.47 {file normalisation .. beyond root (Bug 1379287)} {
- set a [file norm /..]
- set b [file norm /]
- if {![string equal $a $b]} {
- set res "Paths should be equal: $a , $b"
- } else {
- set res "ok"
- }
-} {ok}
+ testPathEqual [file norm /..] [file norm /]
+} ok
test filesystem-1.48 {file normalisation .. beyond root (Bug 1379287)} {
- set a [file norm /../]
- set b [file norm /]
- if {![string equal $a $b]} {
- set res "Paths should be equal: $a , $b"
- } else {
- set res "ok"
- }
-} {ok}
+ testPathEqual [file norm /../] [file norm /]
+} ok
test filesystem-1.49 {file normalisation .. beyond root (Bug 1379287)} {
- set a [file norm /.]
- set b [file norm /]
- if {![string equal $a $b]} {
- set res "Paths should be equal: $a , $b"
- } else {
- set res "ok"
- }
-} {ok}
+ testPathEqual [file norm /.] [file norm /]
+} ok
test filesystem-1.50 {file normalisation .. beyond root (Bug 1379287)} {
- set a [file norm /./]
- set b [file norm /]
- if {![string equal $a $b]} {
- set res "Paths should be equal: $a , $b"
- } else {
- set res "ok"
- }
-} {ok}
+ testPathEqual [file norm /./] [file norm /]
+} ok
test filesystem-1.51 {file normalisation .. beyond root (Bug 1379287)} {
- set a [file norm /../..]
- set b [file norm /]
- if {![string equal $a $b]} {
- set res "Paths should be equal: $a , $b"
- } else {
- set res "ok"
- }
-} {ok}
+ testPathEqual [file norm /../..] [file norm /]
+} ok
test filesystem-1.51.1 {file normalisation .. beyond root (Bug 1379287)} {
- set a [file norm /../../]
- set b [file norm /]
- if {![string equal $a $b]} {
- set res "Paths should be equal: $a , $b"
- } else {
- set res "ok"
- }
-} {ok}
+ testPathEqual [file norm /../../] [file norm /]
+} ok
test filesystem-2.0 {new native path} {unix} {
foreach f [lsort [glob -nocomplain /usr/bin/c*]] {
catch {file readlink $f}
}
# If we reach here we've succeeded. We used to crash above.
- expr 1
-} {1}
+ return ok
+} ok
# Make sure the testfilesystem hasn't been registered.
if {[testConstraint testfilesystem]} {
@@ -511,28 +391,28 @@ test filesystem-4.0 {testfilesystem} -constraints testfilesystem -body {
set filesystemReport {}
file exists foo
testfilesystem 0
- set filesystemReport
+ return $filesystemReport
} -match glob -result {*{access foo}}
test filesystem-4.1 {testfilesystem} -constraints testfilesystem -body {
testfilesystem 1
set filesystemReport {}
catch {file stat foo bar}
testfilesystem 0
- set filesystemReport
+ return $filesystemReport
} -match glob -result {*{stat foo}}
test filesystem-4.2 {testfilesystem} -constraints testfilesystem -body {
testfilesystem 1
set filesystemReport {}
catch {file lstat foo bar}
testfilesystem 0
- set filesystemReport
+ return $filesystemReport
} -match glob -result {*{lstat foo}}
test filesystem-4.3 {testfilesystem} -constraints testfilesystem -body {
testfilesystem 1
set filesystemReport {}
catch {glob *}
testfilesystem 0
- set filesystemReport
+ return $filesystemReport
} -match glob -result {*{matchindirectory *}*}
test filesystem-5.1 {cache and ~} -constraints testfilesystem -setup {
@@ -1041,7 +921,7 @@ test filesystem-9.9 {path objects and glob and file tail and tilde} -setup {
# ----------------------------------------------------------------------
cleanupTests
-unset -nocomplain drive
+unset -nocomplain drive drives
}
namespace delete ::tcl::test::fileSystem
return
diff --git a/tests/init.test b/tests/init.test
index 62b3af2..79d9a04 100644
--- a/tests/init.test
+++ b/tests/init.test
@@ -11,7 +11,7 @@
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
- package require tcltest 2
+ package require tcltest 2.3.3
namespace import -force ::tcltest::*
}
diff --git a/tests/namespace.test b/tests/namespace.test
index 9d7cb59..f4e50bc 100644
--- a/tests/namespace.test
+++ b/tests/namespace.test
@@ -2517,6 +2517,22 @@ test namespace-51.17 {resolution epoch handling: Bug 2898722} -setup {
catch {rename ::c {}}
unset result
} -result {A 1 . A A . B B . B B . B B . B B . G G}
+test namespace-51.18 {Bug 3185407} -setup {
+ namespace eval ::test_ns_1 {}
+} -body {
+ namespace eval ::test_ns_1 {
+ variable result {}
+ namespace eval ns {proc foo {} {}}
+ namespace eval ns2 {proc foo {} {}}
+ namespace path {ns ns2}
+ variable x foo
+ lappend result [namespace which $x]
+ proc foo {} {}
+ lappend result [namespace which $x]
+ }
+} -cleanup {
+ namespace delete ::test_ns_1
+} -result {::test_ns_1::ns::foo ::test_ns_1::foo}
# TIP 181 - namespace unknown tests
test namespace-52.1 {unknown: default handler ::unknown} {
diff --git a/tests/package.test b/tests/package.test
index 55aaf2b..bd57e86 100644
--- a/tests/package.test
+++ b/tests/package.test
@@ -13,7 +13,7 @@
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
- package require tcltest 2
+ package require tcltest 2.3.3
namespace import -force ::tcltest::*
}
diff --git a/tests/socket.test b/tests/socket.test
index e36914f..7f5c5c2 100644
--- a/tests/socket.test
+++ b/tests/socket.test
@@ -822,7 +822,7 @@ test socket_$af-6.2 {
readable fileevent on server socket
} -setup {
set sock [socket -server dummy 0]
-} -body {
+} -constraints [list socket supported_$af] -body {
fileevent $sock readable dummy
} -cleanup {
close $sock
@@ -830,7 +830,7 @@ test socket_$af-6.2 {
test socket_$af-6.3 {writable fileevent on server socket} -setup {
set sock [socket -server dummy 0]
-} -body {
+} -constraints [list socket supported_$af] -body {
fileevent $sock writable dummy
} -cleanup {
close $sock
generated by cgit v0.12 at 2024-11-01 04:54:43 (GMT)