summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2013-02-01 15:32:19 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2013-02-01 15:32:19 (GMT)
commit6f1c949a42ef60692258e34a5dbb8b920d76be23 (patch)
tree0f9df16696586fa30ee3529c7c4cc598a6318a76
parente566dc080bf933404305587e4290769e7e620460 (diff)
parent1153a9400bcdb471e1475c0e40dcf722dd5afc1a (diff)
downloadtcl-6f1c949a42ef60692258e34a5dbb8b920d76be23.zip
tcl-6f1c949a42ef60692258e34a5dbb8b920d76be23.tar.gz
tcl-6f1c949a42ef60692258e34a5dbb8b920d76be23.tar.bz2
merge trunk
-rw-r--r--ChangeLog22
-rw-r--r--generic/tclAssembly.c7
-rw-r--r--generic/tclBinary.c5
-rw-r--r--generic/tclCompExpr.c2
-rw-r--r--generic/tclCompile.c15
-rw-r--r--generic/tclDictObj.c42
-rw-r--r--generic/tclEncoding.c8
-rw-r--r--generic/tclEnsemble.c14
-rw-r--r--generic/tclExecute.c11
-rw-r--r--generic/tclIO.c4
-rw-r--r--generic/tclIndexObj.c26
-rw-r--r--generic/tclInt.h10
-rw-r--r--generic/tclListObj.c2
-rw-r--r--generic/tclOOCall.c11
-rw-r--r--generic/tclOOMethod.c2
-rw-r--r--generic/tclObj.c6
-rw-r--r--generic/tclPathObj.c4
-rw-r--r--generic/tclProc.c27
-rw-r--r--generic/tclRegexp.c10
-rw-r--r--generic/tclStringObj.c4
-rw-r--r--generic/tclTestObj.c8
-rw-r--r--generic/tclThreadAlloc.c12
-rw-r--r--library/auto.tcl25
-rw-r--r--library/init.tcl83
-rw-r--r--library/package.tcl26
-rw-r--r--library/platform/pkgIndex.tcl2
-rw-r--r--library/platform/platform.tcl4
-rw-r--r--library/tcltest/tcltest.tcl198
-rw-r--r--library/tm.tcl10
-rw-r--r--library/word.tcl10
-rw-r--r--tests/assocd.test8
-rw-r--r--tests/basic.test18
-rw-r--r--tests/cmdInfo.test8
-rw-r--r--tests/dcall.test8
-rw-r--r--tests/expr-old.test14
-rw-r--r--tests/main.test26
-rw-r--r--tests/msgcat.test12
-rw-r--r--tests/parse.test27
-rw-r--r--tests/parseExpr.test8
-rw-r--r--tests/parseOld.test22
-rw-r--r--tests/pkgMkIndex.test16
-rw-r--r--tests/platform.test17
-rw-r--r--tests/result.test6
-rw-r--r--tests/stack.test6
-rwxr-xr-xtests/tcltest.test17
-rw-r--r--tests/thread.test22
-rw-r--r--tests/tm.test2
-rw-r--r--tests/trace.test295
-rw-r--r--tests/unixInit.test16
-rw-r--r--tests/unknown.test10
-rw-r--r--unix/Makefile.in39
-rw-r--r--win/Makefile.in4
52 files changed, 573 insertions, 638 deletions
diff --git a/ChangeLog b/ChangeLog
index 0c000b5..a329282 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,25 @@
+2013-01-30 Andreas Kupries <andreask@activestate.com>
+
+ * library/platform/platform.tcl (::platform::LibcVersion): See
+ * library/platform/pkgIndex.tcl: [Bug 3599098]: Fixed the RE
+ * unix/Makefile.in: extracting the version to avoid issues with
+ * win/Makefile.in: recent changes to the glibc banner. Now
+ targeting a less variable part of the string. Bumped package to
+ version 1.0.11.
+
+2013-01-28 Donal K. Fellows <dkf@users.sf.net>
+
+ * generic/tclCompCmds.c (TclCompileArraySetCmd)
+ (TclCompileArrayUnsetCmd, TclCompileDictAppendCmd)
+ (TclCompileDictCreateCmd, CompileDictEachCmd, TclCompileDictIncrCmd)
+ (TclCompileDictLappendCmd, TclCompileDictMergeCmd)
+ (TclCompileDictUnsetCmd, TclCompileDictUpdateCmd)
+ (TclCompileDictWithCmd, TclCompileInfoCommandsCmd):
+ * generic/tclCompCmdsSZ.c (TclCompileStringMatchCmd)
+ (TclCompileStringMapCmd): Improve the code generation in cases where
+ full compilation is impossible but a full ensemble invoke is provably
+ not necessary.
+
2013-01-26 Jan Nijtmans <nijtmans@users.sf.net>
* unix/tclUnixCompat.c: [Bug 3601804]: platformCPUID segmentation
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index c4eeded..0f05d06 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -858,7 +858,7 @@ CompileAssembleObj(
if (objPtr->typePtr == &assembleCodeType) {
namespacePtr = iPtr->varFramePtr->nsPtr;
- codePtr = objPtr->internalRep.otherValuePtr;
+ codePtr = objPtr->internalRep.twoPtrValue.ptr1;
if (((Interp *) *codePtr->interpHandle == iPtr)
&& (codePtr->compileEpoch == iPtr->compileEpoch)
&& (codePtr->nsPtr == namespacePtr)
@@ -943,7 +943,7 @@ CompileAssembleObj(
* Record the local variable context to which the bytecode pertains
*/
- codePtr = objPtr->internalRep.otherValuePtr;
+ codePtr = objPtr->internalRep.twoPtrValue.ptr1;
if (iPtr->varFramePtr->localCachePtr) {
codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
codePtr->localCachePtr->refCount++;
@@ -4336,14 +4336,13 @@ static void
FreeAssembleCodeInternalRep(
Tcl_Obj *objPtr)
{
- ByteCode *codePtr = objPtr->internalRep.otherValuePtr;
+ ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1;
codePtr->refCount--;
if (codePtr->refCount <= 0) {
TclCleanupByteCode(codePtr);
}
objPtr->typePtr = NULL;
- objPtr->internalRep.otherValuePtr = NULL;
}
/*
diff --git a/generic/tclBinary.c b/generic/tclBinary.c
index 455b5a6..d529068 100644
--- a/generic/tclBinary.c
+++ b/generic/tclBinary.c
@@ -204,9 +204,10 @@ typedef struct ByteArray {
#define BYTEARRAY_SIZE(len) \
((unsigned) (TclOffset(ByteArray, bytes) + (len)))
#define GET_BYTEARRAY(objPtr) \
- ((ByteArray *) (objPtr)->internalRep.otherValuePtr)
+ ((ByteArray *) (objPtr)->internalRep.twoPtrValue.ptr1)
#define SET_BYTEARRAY(objPtr, baPtr) \
- (objPtr)->internalRep.otherValuePtr = (void *) (baPtr)
+ (objPtr)->internalRep.twoPtrValue.ptr1 = (VOID *) (baPtr)
+
/*
*----------------------------------------------------------------------
diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c
index 890d518..346f446 100644
--- a/generic/tclCompExpr.c
+++ b/generic/tclCompExpr.c
@@ -2207,7 +2207,7 @@ ExecConstantExprTree(
TclInitByteCodeObj(byteCodeObj, envPtr);
TclFreeCompileEnv(envPtr);
TclStackFree(interp, envPtr);
- byteCodePtr = byteCodeObj->internalRep.otherValuePtr;
+ byteCodePtr = byteCodeObj->internalRep.twoPtrValue.ptr1;
TclNRExecuteByteCode(interp, byteCodePtr);
code = TclNRRunCallbacks(interp, TCL_OK, rootPtr);
Tcl_DecrRefCount(byteCodeObj);
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 45a74d7..33d67ff 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -844,10 +844,9 @@ static void
FreeByteCodeInternalRep(
register Tcl_Obj *objPtr) /* Object whose internal rep to free. */
{
- register ByteCode *codePtr = objPtr->internalRep.otherValuePtr;
+ register ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1;
objPtr->typePtr = NULL;
- objPtr->internalRep.otherValuePtr = NULL;
codePtr->refCount--;
if (codePtr->refCount <= 0) {
TclCleanupByteCode(codePtr);
@@ -867,9 +866,8 @@ FreeByteCodeInternalRep(
* None.
*
* Side effects:
- * Frees objPtr's bytecode internal representation and sets its type and
- * objPtr->internalRep.otherValuePtr NULL. Also releases its literals and
- * frees its auxiliary data items.
+ * Frees objPtr's bytecode internal representation and sets its type NULL
+ * Also releases its literals and frees its auxiliary data items.
*
*----------------------------------------------------------------------
*/
@@ -1144,7 +1142,7 @@ CompileSubstObj(
objPtr->typePtr = &substCodeType;
TclFreeCompileEnv(&compEnv);
- codePtr = objPtr->internalRep.otherValuePtr;
+ codePtr = objPtr->internalRep.twoPtrValue.ptr1;
objPtr->internalRep.ptrAndLongRep.ptr = codePtr;
objPtr->internalRep.ptrAndLongRep.value = flags;
if (iPtr->varFramePtr->localCachePtr) {
@@ -1183,7 +1181,6 @@ FreeSubstCodeInternalRep(
register ByteCode *codePtr = objPtr->internalRep.ptrAndLongRep.ptr;
objPtr->typePtr = NULL;
- objPtr->internalRep.otherValuePtr = NULL;
codePtr->refCount--;
if (codePtr->refCount <= 0) {
TclCleanupByteCode(codePtr);
@@ -2639,7 +2636,7 @@ TclInitByteCodeObj(
*/
TclFreeIntRep(objPtr);
- objPtr->internalRep.otherValuePtr = codePtr;
+ objPtr->internalRep.twoPtrValue.ptr1 = codePtr;
objPtr->typePtr = &tclByteCodeType;
/*
@@ -4058,7 +4055,7 @@ Tcl_Obj *
TclDisassembleByteCodeObj(
Tcl_Obj *objPtr) /* The bytecode object to disassemble. */
{
- ByteCode *codePtr = objPtr->internalRep.otherValuePtr;
+ ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1;
unsigned char *codeStart, *codeLimit, *pc;
unsigned char *codeDeltaNext, *codeLengthNext;
unsigned char *srcDeltaNext, *srcLengthNext;
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index 170e744..6a4ec2f 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -361,7 +361,7 @@ DupDictInternalRep(
Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr)
{
- Dict *oldDict = srcPtr->internalRep.otherValuePtr;
+ Dict *oldDict = srcPtr->internalRep.twoPtrValue.ptr1;
Dict *newDict = ckalloc(sizeof(Dict));
ChainEntry *cPtr;
@@ -396,7 +396,7 @@ DupDictInternalRep(
* Store in the object.
*/
- copyPtr->internalRep.otherValuePtr = newDict;
+ copyPtr->internalRep.twoPtrValue.ptr1 = newDict;
copyPtr->typePtr = &tclDictType;
}
@@ -422,14 +422,12 @@ static void
FreeDictInternalRep(
Tcl_Obj *dictPtr)
{
- Dict *dict = dictPtr->internalRep.otherValuePtr;
+ Dict *dict = dictPtr->internalRep.twoPtrValue.ptr1;
dict->refcount--;
if (dict->refcount <= 0) {
DeleteDict(dict);
}
-
- dictPtr->internalRep.otherValuePtr = NULL; /* Belt and braces! */
dictPtr->typePtr = NULL;
}
@@ -489,7 +487,7 @@ UpdateStringOfDict(
{
#define LOCAL_SIZE 20
int localFlags[LOCAL_SIZE], *flagPtr = NULL;
- Dict *dict = dictPtr->internalRep.otherValuePtr;
+ Dict *dict = dictPtr->internalRep.twoPtrValue.ptr1;
ChainEntry *cPtr;
Tcl_Obj *keyPtr, *valuePtr;
int i, length, bytesNeeded = 0;
@@ -715,7 +713,7 @@ SetDictFromAny(
dict->epoch = 0;
dict->chain = NULL;
dict->refcount = 1;
- objPtr->internalRep.otherValuePtr = dict;
+ objPtr->internalRep.twoPtrValue.ptr1 = dict;
objPtr->typePtr = &tclDictType;
return TCL_OK;
@@ -784,7 +782,7 @@ TclTraceDictPath(
return NULL;
}
}
- dict = dictPtr->internalRep.otherValuePtr;
+ dict = dictPtr->internalRep.twoPtrValue.ptr1;
if (flags & DICT_PATH_UPDATE) {
dict->chain = NULL;
}
@@ -827,7 +825,7 @@ TclTraceDictPath(
}
}
- newDict = tmpObj->internalRep.otherValuePtr;
+ newDict = tmpObj->internalRep.twoPtrValue.ptr1;
if (flags & DICT_PATH_UPDATE) {
if (Tcl_IsShared(tmpObj)) {
TclDecrRefCount(tmpObj);
@@ -835,7 +833,7 @@ TclTraceDictPath(
Tcl_IncrRefCount(tmpObj);
Tcl_SetHashValue(hPtr, tmpObj);
dict->epoch++;
- newDict = tmpObj->internalRep.otherValuePtr;
+ newDict = tmpObj->internalRep.twoPtrValue.ptr1;
}
newDict->chain = dictPtr;
@@ -870,7 +868,7 @@ static void
InvalidateDictChain(
Tcl_Obj *dictObj)
{
- Dict *dict = dictObj->internalRep.otherValuePtr;
+ Dict *dict = dictObj->internalRep.twoPtrValue.ptr1;
do {
Tcl_InvalidateStringRep(dictObj);
@@ -880,7 +878,7 @@ InvalidateDictChain(
break;
}
dict->chain = NULL;
- dict = dictObj->internalRep.otherValuePtr;
+ dict = dictObj->internalRep.twoPtrValue.ptr1;
} while (dict != NULL);
}
@@ -929,7 +927,7 @@ Tcl_DictObjPut(
if (dictPtr->bytes != NULL) {
Tcl_InvalidateStringRep(dictPtr);
}
- dict = dictPtr->internalRep.otherValuePtr;
+ dict = dictPtr->internalRep.twoPtrValue.ptr1;
hPtr = CreateChainEntry(dict, keyPtr, &isNew);
Tcl_IncrRefCount(valuePtr);
if (!isNew) {
@@ -980,7 +978,7 @@ Tcl_DictObjGet(
}
}
- dict = dictPtr->internalRep.otherValuePtr;
+ dict = dictPtr->internalRep.twoPtrValue.ptr1;
hPtr = Tcl_FindHashEntry(&dict->table, keyPtr);
if (hPtr == NULL) {
*valuePtrPtr = NULL;
@@ -1031,7 +1029,7 @@ Tcl_DictObjRemove(
if (dictPtr->bytes != NULL) {
Tcl_InvalidateStringRep(dictPtr);
}
- dict = dictPtr->internalRep.otherValuePtr;
+ dict = dictPtr->internalRep.twoPtrValue.ptr1;
if (DeleteChainEntry(dict, keyPtr)) {
dict->epoch++;
}
@@ -1071,7 +1069,7 @@ Tcl_DictObjSize(
}
}
- dict = dictPtr->internalRep.otherValuePtr;
+ dict = dictPtr->internalRep.twoPtrValue.ptr1;
*sizePtr = dict->table.numEntries;
return TCL_OK;
}
@@ -1126,7 +1124,7 @@ Tcl_DictObjFirst(
}
}
- dict = dictPtr->internalRep.otherValuePtr;
+ dict = dictPtr->internalRep.twoPtrValue.ptr1;
cPtr = dict->entryChainHead;
if (cPtr == NULL) {
searchPtr->epoch = -1;
@@ -1301,7 +1299,7 @@ Tcl_DictObjPutKeyList(
return TCL_ERROR;
}
- dict = dictPtr->internalRep.otherValuePtr;
+ dict = dictPtr->internalRep.twoPtrValue.ptr1;
hPtr = CreateChainEntry(dict, keyv[keyc-1], &isNew);
Tcl_IncrRefCount(valuePtr);
if (!isNew) {
@@ -1357,7 +1355,7 @@ Tcl_DictObjRemoveKeyList(
return TCL_ERROR;
}
- dict = dictPtr->internalRep.otherValuePtr;
+ dict = dictPtr->internalRep.twoPtrValue.ptr1;
DeleteChainEntry(dict, keyv[keyc-1]);
InvalidateDictChain(dictPtr);
return TCL_OK;
@@ -1403,7 +1401,7 @@ Tcl_NewDictObj(void)
dict->epoch = 0;
dict->chain = NULL;
dict->refcount = 1;
- dictPtr->internalRep.otherValuePtr = dict;
+ dictPtr->internalRep.twoPtrValue.ptr1 = dict;
dictPtr->typePtr = &tclDictType;
return dictPtr;
#endif
@@ -1452,7 +1450,7 @@ Tcl_DbNewDictObj(
dict->epoch = 0;
dict->chain = NULL;
dict->refcount = 1;
- dictPtr->internalRep.otherValuePtr = dict;
+ dictPtr->internalRep.twoPtrValue.ptr1 = dict;
dictPtr->typePtr = &tclDictType;
return dictPtr;
#else /* !TCL_MEM_DEBUG */
@@ -2064,7 +2062,7 @@ DictInfoCmd(
return result;
}
}
- dict = dictPtr->internalRep.otherValuePtr;
+ dict = dictPtr->internalRep.twoPtrValue.ptr1;
statsStr = Tcl_HashStats(&dict->table);
Tcl_SetObjResult(interp, Tcl_NewStringObj(statsStr, -1));
diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c
index 7d2206b..86da28c 100644
--- a/generic/tclEncoding.c
+++ b/generic/tclEncoding.c
@@ -271,7 +271,7 @@ static int Iso88591ToUtfProc(ClientData clientData,
int *dstCharsPtr);
/*
- * A Tcl_ObjType for holding a cached Tcl_Encoding in the otherValuePtr field
+ * A Tcl_ObjType for holding a cached Tcl_Encoding in the twoPtrValue.ptr1 field
* of the intrep. This should help the lifetime of encodings be more useful.
* See concerns raised in [Bug 1077262].
*/
@@ -314,7 +314,7 @@ Tcl_GetEncodingFromObj(
return TCL_ERROR;
}
TclFreeIntRep(objPtr);
- objPtr->internalRep.otherValuePtr = encoding;
+ objPtr->internalRep.twoPtrValue.ptr1 = encoding;
objPtr->typePtr = &encodingType;
}
*encodingPtr = Tcl_GetEncoding(NULL, name);
@@ -335,7 +335,7 @@ static void
FreeEncodingIntRep(
Tcl_Obj *objPtr)
{
- Tcl_FreeEncoding(objPtr->internalRep.otherValuePtr);
+ Tcl_FreeEncoding(objPtr->internalRep.twoPtrValue.ptr1);
objPtr->typePtr = NULL;
}
@@ -354,7 +354,7 @@ DupEncodingIntRep(
Tcl_Obj *srcPtr,
Tcl_Obj *dupPtr)
{
- dupPtr->internalRep.otherValuePtr = Tcl_GetEncoding(NULL, srcPtr->bytes);
+ dupPtr->internalRep.twoPtrValue.ptr1 = Tcl_GetEncoding(NULL, srcPtr->bytes);
}
/*
diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c
index f392cad..bf9dac2 100644
--- a/generic/tclEnsemble.c
+++ b/generic/tclEnsemble.c
@@ -1718,7 +1718,7 @@ NsEnsembleImplementationCmdNR(
if (objv[1+ensemblePtr->numParameters]->typePtr==&tclEnsembleCmdType){
EnsembleCmdRep *ensembleCmd = objv[1+ensemblePtr->numParameters]
- ->internalRep.otherValuePtr;
+ ->internalRep.twoPtrValue.ptr1;
if (ensembleCmd->nsPtr == ensemblePtr->nsPtr &&
ensembleCmd->epoch == ensemblePtr->epoch &&
@@ -2238,7 +2238,7 @@ MakeCachedEnsembleCommand(
int length;
if (objPtr->typePtr == &tclEnsembleCmdType) {
- ensembleCmd = objPtr->internalRep.otherValuePtr;
+ ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1;
Tcl_DecrRefCount(ensembleCmd->realPrefixObj);
TclNsDecrRefCount(ensembleCmd->nsPtr);
ckfree(ensembleCmd->fullSubcmdName);
@@ -2250,7 +2250,7 @@ MakeCachedEnsembleCommand(
TclFreeIntRep(objPtr);
ensembleCmd = ckalloc(sizeof(EnsembleCmdRep));
- objPtr->internalRep.otherValuePtr = ensembleCmd;
+ objPtr->internalRep.twoPtrValue.ptr1 = ensembleCmd;
objPtr->typePtr = &tclEnsembleCmdType;
}
@@ -2645,7 +2645,7 @@ static void
FreeEnsembleCmdRep(
Tcl_Obj *objPtr)
{
- EnsembleCmdRep *ensembleCmd = objPtr->internalRep.otherValuePtr;
+ EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1;
Tcl_DecrRefCount(ensembleCmd->realPrefixObj);
ckfree(ensembleCmd->fullSubcmdName);
@@ -2677,12 +2677,12 @@ DupEnsembleCmdRep(
Tcl_Obj *objPtr,
Tcl_Obj *copyPtr)
{
- EnsembleCmdRep *ensembleCmd = objPtr->internalRep.otherValuePtr;
+ EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1;
EnsembleCmdRep *ensembleCopy = ckalloc(sizeof(EnsembleCmdRep));
int length = strlen(ensembleCmd->fullSubcmdName);
copyPtr->typePtr = &tclEnsembleCmdType;
- copyPtr->internalRep.otherValuePtr = ensembleCopy;
+ copyPtr->internalRep.twoPtrValue.ptr1 = ensembleCopy;
ensembleCopy->nsPtr = ensembleCmd->nsPtr;
ensembleCopy->epoch = ensembleCmd->epoch;
ensembleCopy->token = ensembleCmd->token;
@@ -2715,7 +2715,7 @@ static void
StringOfEnsembleCmdRep(
Tcl_Obj *objPtr)
{
- EnsembleCmdRep *ensembleCmd = objPtr->internalRep.otherValuePtr;
+ EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1;
int length = strlen(ensembleCmd->fullSubcmdName);
objPtr->length = length;
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index c2cef2a..be2e3ca 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -1494,7 +1494,7 @@ CompileExprObj(
if (objPtr->typePtr == &exprCodeType) {
Namespace *namespacePtr = iPtr->varFramePtr->nsPtr;
- codePtr = objPtr->internalRep.otherValuePtr;
+ codePtr = objPtr->internalRep.twoPtrValue.ptr1;
if (((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)
|| (codePtr->nsPtr != namespacePtr)
@@ -1534,7 +1534,7 @@ CompileExprObj(
TclInitByteCodeObj(objPtr, &compEnv);
objPtr->typePtr = &exprCodeType;
TclFreeCompileEnv(&compEnv);
- codePtr = objPtr->internalRep.otherValuePtr;
+ codePtr = objPtr->internalRep.twoPtrValue.ptr1;
if (iPtr->varFramePtr->localCachePtr) {
codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
codePtr->localCachePtr->refCount++;
@@ -1606,10 +1606,9 @@ static void
FreeExprCodeInternalRep(
Tcl_Obj *objPtr)
{
- ByteCode *codePtr = objPtr->internalRep.otherValuePtr;
+ ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1;
objPtr->typePtr = NULL;
- objPtr->internalRep.otherValuePtr = NULL;
codePtr->refCount--;
if (codePtr->refCount <= 0) {
TclCleanupByteCode(codePtr);
@@ -1667,7 +1666,7 @@ TclCompileObj(
* here.
*/
- codePtr = objPtr->internalRep.otherValuePtr;
+ codePtr = objPtr->internalRep.twoPtrValue.ptr1;
if (((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)
|| (codePtr->nsPtr != namespacePtr)
@@ -1795,7 +1794,7 @@ TclCompileObj(
iPtr->invokeWord = word;
TclSetByteCodeFromAny(interp, objPtr, NULL, NULL);
iPtr->invokeCmdFramePtr = NULL;
- codePtr = objPtr->internalRep.otherValuePtr;
+ codePtr = objPtr->internalRep.twoPtrValue.ptr1;
if (iPtr->varFramePtr->localCachePtr) {
codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
codePtr->localCachePtr->refCount++;
diff --git a/generic/tclIO.c b/generic/tclIO.c
index 715c1ef..f340d59 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -221,9 +221,9 @@ static const Tcl_ObjType tclChannelType = {
};
#define GET_CHANNELSTATE(objPtr) \
- ((ChannelState *) (objPtr)->internalRep.otherValuePtr)
+ ((ChannelState *) (objPtr)->internalRep.twoPtrValue.ptr1)
#define SET_CHANNELSTATE(objPtr, storePtr) \
- ((objPtr)->internalRep.otherValuePtr = (void *) (storePtr))
+ ((objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (storePtr))
#define GET_CHANNELINTERP(objPtr) \
((Interp *) (objPtr)->internalRep.twoPtrValue.ptr2)
#define SET_CHANNELINTERP(objPtr, storePtr) \
diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c
index 0372668..29cdbbb 100644
--- a/generic/tclIndexObj.c
+++ b/generic/tclIndexObj.c
@@ -53,7 +53,7 @@ static const Tcl_ObjType indexType = {
/*
* The definition of the internal representation of the "index" object; The
- * internalRep.otherValuePtr field of an object of "index" type will be a
+ * internalRep.twoPtrValue.ptr1 field of an object of "index" type will be a
* pointer to one of these structures.
*
* Keep this structure declaration in sync with tclTestObj.c
@@ -121,7 +121,7 @@ Tcl_GetIndexFromObj(
*/
if (objPtr->typePtr == &indexType) {
- IndexRep *indexRep = objPtr->internalRep.otherValuePtr;
+ IndexRep *indexRep = objPtr->internalRep.twoPtrValue.ptr1;
/*
* Here's hoping we don't get hit by unfortunate packing constraints
@@ -279,7 +279,7 @@ Tcl_GetIndexFromObjStruct(
*/
if (objPtr->typePtr == &indexType) {
- indexRep = objPtr->internalRep.otherValuePtr;
+ indexRep = objPtr->internalRep.twoPtrValue.ptr1;
if (indexRep->tablePtr==tablePtr && indexRep->offset==offset) {
*indexPtr = indexRep->index;
return TCL_OK;
@@ -340,11 +340,11 @@ Tcl_GetIndexFromObjStruct(
*/
if (objPtr->typePtr == &indexType) {
- indexRep = objPtr->internalRep.otherValuePtr;
+ indexRep = objPtr->internalRep.twoPtrValue.ptr1;
} else {
TclFreeIntRep(objPtr);
indexRep = ckalloc(sizeof(IndexRep));
- objPtr->internalRep.otherValuePtr = indexRep;
+ objPtr->internalRep.twoPtrValue.ptr1 = indexRep;
objPtr->typePtr = &indexType;
}
indexRep->tablePtr = (void *) tablePtr;
@@ -447,7 +447,7 @@ static void
UpdateStringOfIndex(
Tcl_Obj *objPtr)
{
- IndexRep *indexRep = objPtr->internalRep.otherValuePtr;
+ IndexRep *indexRep = objPtr->internalRep.twoPtrValue.ptr1;
register char *buf;
register unsigned len;
register const char *indexStr = EXPAND_OF(indexRep);
@@ -482,11 +482,11 @@ DupIndex(
Tcl_Obj *srcPtr,
Tcl_Obj *dupPtr)
{
- IndexRep *srcIndexRep = srcPtr->internalRep.otherValuePtr;
+ IndexRep *srcIndexRep = srcPtr->internalRep.twoPtrValue.ptr1;
IndexRep *dupIndexRep = ckalloc(sizeof(IndexRep));
memcpy(dupIndexRep, srcIndexRep, sizeof(IndexRep));
- dupPtr->internalRep.otherValuePtr = dupIndexRep;
+ dupPtr->internalRep.twoPtrValue.ptr1 = dupIndexRep;
dupPtr->typePtr = &indexType;
}
@@ -511,7 +511,7 @@ static void
FreeIndex(
Tcl_Obj *objPtr)
{
- ckfree(objPtr->internalRep.otherValuePtr);
+ ckfree(objPtr->internalRep.twoPtrValue.ptr1);
objPtr->typePtr = NULL;
}
@@ -952,13 +952,13 @@ Tcl_WrongNumArgs(
if (origObjv[i]->typePtr == &indexType) {
register IndexRep *indexRep =
- origObjv[i]->internalRep.otherValuePtr;
+ origObjv[i]->internalRep.twoPtrValue.ptr1;
elementStr = EXPAND_OF(indexRep);
elemLen = strlen(elementStr);
} else if (origObjv[i]->typePtr == &tclEnsembleCmdType) {
register EnsembleCmdRep *ecrPtr =
- origObjv[i]->internalRep.otherValuePtr;
+ origObjv[i]->internalRep.twoPtrValue.ptr1;
elementStr = ecrPtr->fullSubcmdName;
elemLen = strlen(elementStr);
@@ -1007,12 +1007,12 @@ Tcl_WrongNumArgs(
*/
if (objv[i]->typePtr == &indexType) {
- register IndexRep *indexRep = objv[i]->internalRep.otherValuePtr;
+ register IndexRep *indexRep = objv[i]->internalRep.twoPtrValue.ptr1;
Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), NULL);
} else if (objv[i]->typePtr == &tclEnsembleCmdType) {
register EnsembleCmdRep *ecrPtr =
- objv[i]->internalRep.otherValuePtr;
+ objv[i]->internalRep.twoPtrValue.ptr1;
Tcl_AppendStringsToObj(objPtr, ecrPtr->fullSubcmdName, NULL);
} else {
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 18768d9..6a63f54 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -396,7 +396,7 @@ struct NamespacePathEntry {
/*
* The data cached in an ensemble subcommand's Tcl_Obj rep (reference in
- * otherValuePtr field). This structure is not shared between Tcl_Objs
+ * twoPtrValue.ptr1 field). This structure is not shared between Tcl_Objs
* referring to the same subcommand, even where one is a duplicate of another.
*/
@@ -4088,7 +4088,7 @@ MODULE_SCOPE void TclpFreeAllocCache(void *);
(objPtr) = TclThreadAllocObj(); \
} else { \
(objPtr) = cachePtr->firstObjPtr; \
- cachePtr->firstObjPtr = (objPtr)->internalRep.otherValuePtr; \
+ cachePtr->firstObjPtr = (objPtr)->internalRep.twoPtrValue.ptr1; \
--cachePtr->numObjects; \
} \
} while (0)
@@ -4101,7 +4101,7 @@ MODULE_SCOPE void TclpFreeAllocCache(void *);
(cachePtr->numObjects >= ALLOC_NOBJHIGH))) { \
TclThreadFreeObj(objPtr); \
} else { \
- (objPtr)->internalRep.otherValuePtr = cachePtr->firstObjPtr; \
+ (objPtr)->internalRep.twoPtrValue.ptr1 = cachePtr->firstObjPtr; \
cachePtr->firstObjPtr = objPtr; \
++cachePtr->numObjects; \
} \
@@ -4129,14 +4129,14 @@ MODULE_SCOPE Tcl_Mutex tclObjMutex;
} \
(objPtr) = tclFreeObjList; \
tclFreeObjList = (Tcl_Obj *) \
- tclFreeObjList->internalRep.otherValuePtr; \
+ tclFreeObjList->internalRep.twoPtrValue.ptr1; \
Tcl_MutexUnlock(&tclObjMutex); \
} while (0)
# define TclFreeObjStorageEx(interp, objPtr) \
do { \
Tcl_MutexLock(&tclObjMutex); \
- (objPtr)->internalRep.otherValuePtr = (void *) tclFreeObjList; \
+ (objPtr)->internalRep.twoPtrValue.ptr1 = (void *) tclFreeObjList; \
tclFreeObjList = (objPtr); \
Tcl_MutexUnlock(&tclObjMutex); \
} while (0)
diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index 2d1defa..865e402 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -1736,8 +1736,6 @@ FreeListInternalRep(
ckfree(listRepPtr);
}
- listPtr->internalRep.twoPtrValue.ptr1 = NULL;
- listPtr->internalRep.twoPtrValue.ptr2 = NULL;
listPtr->typePtr = NULL;
}
diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c
index a79e4fa..26fd09f 100644
--- a/generic/tclOOCall.c
+++ b/generic/tclOOCall.c
@@ -178,7 +178,7 @@ StashCallChain(
callPtr->refCount++;
TclFreeIntRep(objPtr);
objPtr->typePtr = &methodNameType;
- objPtr->internalRep.otherValuePtr = callPtr;
+ objPtr->internalRep.twoPtrValue.ptr1 = callPtr;
}
void
@@ -205,10 +205,10 @@ DupMethodNameRep(
Tcl_Obj *srcPtr,
Tcl_Obj *dstPtr)
{
- register CallChain *callPtr = srcPtr->internalRep.otherValuePtr;
+ register CallChain *callPtr = srcPtr->internalRep.twoPtrValue.ptr1;
dstPtr->typePtr = &methodNameType;
- dstPtr->internalRep.otherValuePtr = callPtr;
+ dstPtr->internalRep.twoPtrValue.ptr1 = callPtr;
callPtr->refCount++;
}
@@ -216,10 +216,9 @@ static void
FreeMethodNameRep(
Tcl_Obj *objPtr)
{
- register CallChain *callPtr = objPtr->internalRep.otherValuePtr;
+ register CallChain *callPtr = objPtr->internalRep.twoPtrValue.ptr1;
TclOODeleteChain(callPtr);
- objPtr->internalRep.otherValuePtr = NULL;
objPtr->typePtr = NULL;
}
@@ -952,7 +951,7 @@ TclOOGetCallContext(
const int reuseMask = ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD);
if (cacheInThisObj->typePtr == &methodNameType) {
- callPtr = cacheInThisObj->internalRep.otherValuePtr;
+ callPtr = cacheInThisObj->internalRep.twoPtrValue.ptr1;
if (IsStillValid(callPtr, oPtr, flags, reuseMask)) {
callPtr->refCount++;
goto returnContext;
diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c
index 28820e0..98b4078 100644
--- a/generic/tclOOMethod.c
+++ b/generic/tclOOMethod.c
@@ -860,7 +860,7 @@ PushMethodCallFrame(
if (pmPtr->procPtr->bodyPtr->typePtr == &tclByteCodeType) {
ByteCode *codePtr =
- pmPtr->procPtr->bodyPtr->internalRep.otherValuePtr;
+ pmPtr->procPtr->bodyPtr->internalRep.twoPtrValue.ptr1;
codePtr->nsPtr = nsPtr;
}
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 74cb29e..1d86534 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -1255,7 +1255,7 @@ Tcl_DbNewObj(
* Side effects:
* tclFreeObjList, the head of the list of free Tcl_Objs, is set to the
* first of a number of free Tcl_Obj's linked together by their
- * internalRep.otherValuePtrs.
+ * internalRep.twoPtrValue.ptr1's.
*
*----------------------------------------------------------------------
*/
@@ -1284,7 +1284,7 @@ TclAllocateFreeObjects(void)
prevPtr = NULL;
objPtr = (Tcl_Obj *) basePtr;
for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) {
- objPtr->internalRep.otherValuePtr = prevPtr;
+ objPtr->internalRep.twoPtrValue.ptr1 = prevPtr;
prevPtr = objPtr;
objPtr++;
}
@@ -4390,7 +4390,7 @@ SetCmdNameFromAny(
if (cmdPtr) {
cmdPtr->refCount++;
- resPtr = objPtr->internalRep.otherValuePtr;
+ resPtr = objPtr->internalRep.twoPtrValue.ptr1;
if ((objPtr->typePtr == &tclCmdNameType)
&& resPtr && (resPtr->refCount == 1)) {
/*
diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c
index 2b9ff87..b3ead45 100644
--- a/generic/tclPathObj.c
+++ b/generic/tclPathObj.c
@@ -109,9 +109,9 @@ typedef struct FsPath {
* fields.
*/
-#define PATHOBJ(pathPtr) ((FsPath *) (pathPtr)->internalRep.otherValuePtr)
+#define PATHOBJ(pathPtr) ((FsPath *) (pathPtr)->internalRep.twoPtrValue.ptr1)
#define SETPATHOBJ(pathPtr,fsPathPtr) \
- ((pathPtr)->internalRep.otherValuePtr = (void *) (fsPathPtr))
+ ((pathPtr)->internalRep.twoPtrValue.ptr1 = (void *) (fsPathPtr))
#define PATHFLAGS(pathPtr) (PATHOBJ(pathPtr)->flags)
/*
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 933e7d2..a261cd4 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -421,7 +421,7 @@ TclCreateProc(
* will be holding a reference to it.
*/
- procPtr = bodyPtr->internalRep.otherValuePtr;
+ procPtr = bodyPtr->internalRep.twoPtrValue.ptr1;
procPtr->iPtr = iPtr;
procPtr->refCount++;
precompiled = 1;
@@ -1197,7 +1197,7 @@ TclInitCompiledLocals(
if (bodyPtr->typePtr != &tclByteCodeType) {
Tcl_Panic("body object for proc attached to frame is not a byte code type");
}
- codePtr = bodyPtr->internalRep.otherValuePtr;
+ codePtr = bodyPtr->internalRep.twoPtrValue.ptr1;
if (framePtr->numCompiledLocals) {
if (!codePtr->localCachePtr) {
@@ -1368,7 +1368,7 @@ InitLocalCache(
Proc *procPtr)
{
Interp *iPtr = procPtr->iPtr;
- ByteCode *codePtr = procPtr->bodyPtr->internalRep.otherValuePtr;
+ ByteCode *codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1;
int localCt = procPtr->numCompiledLocals;
int numArgs = procPtr->numArgs, i = 0;
@@ -1445,7 +1445,7 @@ InitArgsAndLocals(
{
CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
register Proc *procPtr = framePtr->procPtr;
- ByteCode *codePtr = procPtr->bodyPtr->internalRep.otherValuePtr;
+ ByteCode *codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1;
register Var *varPtr, *defPtr;
int localCt = procPtr->numCompiledLocals, numArgs, argCt, i, imax;
Tcl_Obj *const *argObjs;
@@ -1632,7 +1632,7 @@ PushProcCallFrame(
* commands and/or resolver changes are considered).
*/
- codePtr = procPtr->bodyPtr->internalRep.otherValuePtr;
+ codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1;
if (((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)
|| (codePtr->nsPtr != nsPtr)
@@ -1833,7 +1833,7 @@ TclNRInterpProcCore(
*/
procPtr->refCount++;
- codePtr = procPtr->bodyPtr->internalRep.otherValuePtr;
+ codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1;
TclNRAddCallback(interp, InterpProcNR2, procNameObj, errorProc,
NULL, NULL);
@@ -1975,7 +1975,7 @@ TclProcCompileProc(
{
Interp *iPtr = (Interp *) interp;
Tcl_CallFrame *framePtr;
- ByteCode *codePtr = bodyPtr->internalRep.otherValuePtr;
+ ByteCode *codePtr = bodyPtr->internalRep.twoPtrValue.ptr1;
/*
* If necessary, compile the procedure's body. The compiler will allocate
@@ -2365,7 +2365,7 @@ TclNewProcBodyObj(
TclNewObj(objPtr);
if (objPtr) {
objPtr->typePtr = &tclProcBodyType;
- objPtr->internalRep.otherValuePtr = procPtr;
+ objPtr->internalRep.twoPtrValue.ptr1 = procPtr;
procPtr->refCount++;
}
@@ -2395,10 +2395,10 @@ ProcBodyDup(
Tcl_Obj *srcPtr, /* Object to copy. */
Tcl_Obj *dupPtr) /* Target object for the duplication. */
{
- Proc *procPtr = srcPtr->internalRep.otherValuePtr;
+ Proc *procPtr = srcPtr->internalRep.twoPtrValue.ptr1;
dupPtr->typePtr = &tclProcBodyType;
- dupPtr->internalRep.otherValuePtr = procPtr;
+ dupPtr->internalRep.twoPtrValue.ptr1 = procPtr;
procPtr->refCount++;
}
@@ -2425,10 +2425,9 @@ static void
ProcBodyFree(
Tcl_Obj *objPtr) /* The object to clean up. */
{
- Proc *procPtr = objPtr->internalRep.otherValuePtr;
+ Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1;
- procPtr->refCount--;
- if (procPtr->refCount <= 0) {
+ if (procPtr->refCount-- < 2) {
TclProcCleanupProc(procPtr);
}
}
@@ -3061,7 +3060,7 @@ Tcl_DisassembleObjCmd(
* Do the actual disassembly.
*/
- if (((ByteCode *) codeObjPtr->internalRep.otherValuePtr)->flags
+ if (((ByteCode *) codeObjPtr->internalRep.twoPtrValue.ptr1)->flags
& TCL_BYTECODE_PRECOMPILED) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"may not disassemble prebuilt bytecode", -1));
diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c
index 6c1dc08..6348e4a 100644
--- a/generic/tclRegexp.c
+++ b/generic/tclRegexp.c
@@ -578,7 +578,7 @@ Tcl_GetRegExpFromObj(
* TclRegexp* when the type is tclRegexpType.
*/
- regexpPtr = objPtr->internalRep.otherValuePtr;
+ regexpPtr = objPtr->internalRep.twoPtrValue.ptr1;
if ((objPtr->typePtr != &tclRegexpType) || (regexpPtr->flags != flags)) {
pattern = TclGetStringFromObj(objPtr, &length);
@@ -601,7 +601,7 @@ Tcl_GetRegExpFromObj(
*/
TclFreeIntRep(objPtr);
- objPtr->internalRep.otherValuePtr = regexpPtr;
+ objPtr->internalRep.twoPtrValue.ptr1 = regexpPtr;
objPtr->typePtr = &tclRegexpType;
}
return (Tcl_RegExp) regexpPtr;
@@ -749,7 +749,7 @@ static void
FreeRegexpInternalRep(
Tcl_Obj *objPtr) /* Regexp object with internal rep to free. */
{
- TclRegexp *regexpRepPtr = objPtr->internalRep.otherValuePtr;
+ TclRegexp *regexpRepPtr = objPtr->internalRep.twoPtrValue.ptr1;
/*
* If this is the last reference to the regexp, free it.
@@ -783,10 +783,10 @@ DupRegexpInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
- TclRegexp *regexpPtr = srcPtr->internalRep.otherValuePtr;
+ TclRegexp *regexpPtr = srcPtr->internalRep.twoPtrValue.ptr1;
regexpPtr->refCount++;
- copyPtr->internalRep.otherValuePtr = srcPtr->internalRep.otherValuePtr;
+ copyPtr->internalRep.twoPtrValue.ptr1 = srcPtr->internalRep.twoPtrValue.ptr1;
copyPtr->typePtr = &tclRegexpType;
}
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 04cf4ee..e495c2e 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -140,9 +140,9 @@ typedef struct String {
#define stringAttemptRealloc(ptr, numChars) \
(String *) attemptckrealloc((ptr), (unsigned) STRING_SIZE(numChars) )
#define GET_STRING(objPtr) \
- ((String *) (objPtr)->internalRep.otherValuePtr)
+ ((String *) (objPtr)->internalRep.twoPtrValue.ptr1)
#define SET_STRING(objPtr, stringPtr) \
- ((objPtr)->internalRep.otherValuePtr = (void *) (stringPtr))
+ ((objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (stringPtr))
/*
* TCL STRING GROWTH ALGORITHM
diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c
index 4bddc42..f36b07f 100644
--- a/generic/tclTestObj.c
+++ b/generic/tclTestObj.c
@@ -555,7 +555,7 @@ TestindexobjCmd(
}
Tcl_GetIndexFromObj(NULL, objv[1], tablePtr, "token", 0, &index);
- indexRep = objv[1]->internalRep.otherValuePtr;
+ indexRep = objv[1]->internalRep.twoPtrValue.ptr1;
indexRep->index = index2;
result = Tcl_GetIndexFromObj(NULL, objv[1],
tablePtr, "token", 0, &index);
@@ -592,7 +592,7 @@ TestindexobjCmd(
if (objv[3]->typePtr != NULL
&& !strcmp("index", objv[3]->typePtr->name)) {
- indexRep = objv[3]->internalRep.otherValuePtr;
+ indexRep = objv[3]->internalRep.twoPtrValue.ptr1;
if (indexRep->tablePtr == (void *) argv) {
TclFreeIntRep(objv[3]);
}
@@ -1250,7 +1250,7 @@ TeststringobjCmd(
if (varPtr[varIndex] != NULL) {
Tcl_ConvertToType(NULL, varPtr[varIndex],
Tcl_GetObjType("string"));
- strPtr = varPtr[varIndex]->internalRep.otherValuePtr;
+ strPtr = varPtr[varIndex]->internalRep.twoPtrValue.ptr1;
length = (int) strPtr->allocated;
} else {
length = -1;
@@ -1304,7 +1304,7 @@ TeststringobjCmd(
if (varPtr[varIndex] != NULL) {
Tcl_ConvertToType(NULL, varPtr[varIndex],
Tcl_GetObjType("string"));
- strPtr = varPtr[varIndex]->internalRep.otherValuePtr;
+ strPtr = varPtr[varIndex]->internalRep.twoPtrValue.ptr1;
length = strPtr->maxChars;
} else {
length = -1;
diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c
index e4261d6..abd5af5 100644
--- a/generic/tclThreadAlloc.c
+++ b/generic/tclThreadAlloc.c
@@ -573,7 +573,7 @@ TclThreadAllocObj(void)
}
while (--numMove >= 0) {
objPtr = &newObjsPtr[numMove];
- objPtr->internalRep.otherValuePtr = cachePtr->firstObjPtr;
+ objPtr->internalRep.twoPtrValue.ptr1 = cachePtr->firstObjPtr;
cachePtr->firstObjPtr = objPtr;
}
}
@@ -584,7 +584,7 @@ TclThreadAllocObj(void)
*/
objPtr = cachePtr->firstObjPtr;
- cachePtr->firstObjPtr = objPtr->internalRep.otherValuePtr;
+ cachePtr->firstObjPtr = objPtr->internalRep.twoPtrValue.ptr1;
cachePtr->numObjects--;
return objPtr;
}
@@ -621,7 +621,7 @@ TclThreadFreeObj(
* Get this thread's list and push on the free Tcl_Obj.
*/
- objPtr->internalRep.otherValuePtr = cachePtr->firstObjPtr;
+ objPtr->internalRep.twoPtrValue.ptr1 = cachePtr->firstObjPtr;
cachePtr->firstObjPtr = objPtr;
cachePtr->numObjects++;
@@ -722,16 +722,16 @@ MoveObjs(
*/
while (--numMove) {
- objPtr = objPtr->internalRep.otherValuePtr;
+ objPtr = objPtr->internalRep.twoPtrValue.ptr1;
}
- fromPtr->firstObjPtr = objPtr->internalRep.otherValuePtr;
+ fromPtr->firstObjPtr = objPtr->internalRep.twoPtrValue.ptr1;
/*
* Move all objects as a block - they are already linked to each other, we
* just have to update the first and last.
*/
- objPtr->internalRep.otherValuePtr = toPtr->firstObjPtr;
+ objPtr->internalRep.twoPtrValue.ptr1 = toPtr->firstObjPtr;
toPtr->firstObjPtr = fromFirstObjPtr;
}
diff --git a/library/auto.tcl b/library/auto.tcl
index 4bd860d..e86257e 100644
--- a/library/auto.tcl
+++ b/library/auto.tcl
@@ -20,8 +20,9 @@
# None.
proc auto_reset {} {
- if {[array exists ::auto_index]} {
- foreach cmdName [array names ::auto_index] {
+ global auto_execs auto_index auto_path
+ if {[array exists auto_index]} {
+ foreach cmdName [array names auto_index] {
set fqcn [namespace which $cmdName]
if {$fqcn eq ""} {
continue
@@ -29,11 +30,11 @@ proc auto_reset {} {
rename $fqcn {}
}
}
- unset -nocomplain ::auto_execs ::auto_index ::tcl::auto_oldpath
- if {[catch {llength $::auto_path}]} {
- set ::auto_path [list [info library]]
- } elseif {[info library] ni $::auto_path} {
- lappend ::auto_path [info library]
+ unset -nocomplain auto_execs auto_index ::tcl::auto_oldpath
+ if {[catch {llength $auto_path}]} {
+ set auto_path [list [info library]]
+ } elseif {[info library] ni $auto_path} {
+ lappend auto_path [info library]
}
}
@@ -53,7 +54,7 @@ proc auto_reset {} {
proc tcl_findLibrary {basename version patch initScript enVarName varName} {
upvar #0 $varName the_library
- global env
+ global auto_path env tcl_platform
set dirs {}
set errors {}
@@ -83,12 +84,10 @@ proc tcl_findLibrary {basename version patch initScript enVarName varName} {
# 3. Relative to auto_path directories. This checks relative to the
# Tcl library as well as allowing loading of libraries added to the
# auto_path that is not relative to the core library or binary paths.
- foreach d $::auto_path {
+ foreach d $auto_path {
lappend dirs [file join $d $basename$version]
- if {
- $::tcl_platform(platform) eq "unix"
- && $::tcl_platform(os) eq "Darwin"
- } then {
+ if {$tcl_platform(platform) eq "unix"
+ && $tcl_platform(os) eq "Darwin"} {
# 4. On MacOSX, check the Resources/Scripts subdir too
lappend dirs [file join $d $basename$version Resources Scripts]
}
diff --git a/library/init.tcl b/library/init.tcl
index e836df9..bedc06e 100644
--- a/library/init.tcl
+++ b/library/init.tcl
@@ -12,6 +12,7 @@
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
+# This test intentionally written in pre-7.5 Tcl
if {[info commands package] == ""} {
error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]"
}
@@ -116,9 +117,10 @@ namespace eval tcl {
if {(![interp issafe]) && ($tcl_platform(platform) eq "windows")} {
namespace eval tcl {
proc EnvTraceProc {lo n1 n2 op} {
- set x $::env($n2)
- set ::env($lo) $x
- set ::env([string toupper $lo]) $x
+ global env
+ set x $env($n2)
+ set env($lo) $x
+ set env([string toupper $lo]) $x
}
proc InitWinEnv {} {
global env tcl_platform
@@ -159,8 +161,8 @@ if {[interp issafe]} {
} else {
# Set up search for Tcl Modules (TIP #189).
# and setup platform specific unknown package handlers
- if {$::tcl_platform(os) eq "Darwin"
- && $::tcl_platform(platform) eq "unix"} {
+ if {$tcl_platform(os) eq "Darwin"
+ && $tcl_platform(platform) eq "unix"} {
package unknown {::tcl::tm::UnknownHandler \
{::tcl::MacOSXPkgUnknown ::tclPkgUnknown}}
} else {
@@ -233,14 +235,13 @@ if {[namespace which -command tclLog] eq ""} {
proc unknown args {
variable ::tcl::UnknownPending
- global auto_noexec auto_noload env tcl_interactive
+ global auto_noexec auto_noload env tcl_interactive errorInfo errorCode
-
- if {[info exists ::errorInfo]} {
- set savedErrorInfo $::errorInfo
+ if {[info exists errorInfo]} {
+ set savedErrorInfo $errorInfo
}
- if {[info exists ::errorCode]} {
- set savedErrorCode $::errorCode
+ if {[info exists errorCode]} {
+ set savedErrorCode $errorCode
}
set name [lindex $args 0]
@@ -271,9 +272,9 @@ proc unknown args {
unset -nocomplain ::errorCode
}
if {[info exists savedErrorInfo]} {
- set ::errorInfo $savedErrorInfo
+ set errorInfo $savedErrorInfo
} else {
- unset -nocomplain ::errorInfo
+ unset -nocomplain errorInfo
}
set code [catch {uplevel 1 $args} msg opts]
if {$code == 1} {
@@ -282,8 +283,8 @@ proc unknown args {
# Note the dependence on how Tcl_AddErrorInfo, etc.
# construct the stack trace.
#
- set errorInfo [dict get $opts -errorinfo]
- set errorCode [dict get $opts -errorcode]
+ set errInfo [dict get $opts -errorinfo]
+ set errCode [dict get $opts -errorcode]
set cinfo $args
if {[string bytelength $cinfo] > 150} {
set cinfo [string range $cinfo 0 150]
@@ -300,7 +301,7 @@ proc unknown args {
# and trim the extra contribution from the matching case
#
set expect "$msg\n while executing\n\"$cinfo"
- if {$errorInfo eq $expect} {
+ if {$errInfo eq $expect} {
#
# The stack has only the eval from the expanded command
# Do not generate any stack trace here.
@@ -315,18 +316,18 @@ proc unknown args {
#
set expect "\n invoked from within\n\"$cinfo"
set exlen [string length $expect]
- set eilen [string length $errorInfo]
+ set eilen [string length $errInfo]
set i [expr {$eilen - $exlen - 1}]
- set einfo [string range $errorInfo 0 $i]
+ set einfo [string range $errInfo 0 $i]
#
- # For now verify that $errorInfo consists of what we are about
+ # For now verify that $errInfo consists of what we are about
# to return plus what we expected to trim off.
#
- if {$errorInfo ne "$einfo$expect"} {
+ if {$errInfo ne "$einfo$expect"} {
error "Tcl bug: unexpected stack trace in \"unknown\"" {} \
- [list CORE UNKNOWN BADTRACE $einfo $expect $errorInfo]
+ [list CORE UNKNOWN BADTRACE $einfo $expect $errInfo]
}
- return -code error -errorcode $errorCode \
+ return -code error -errorcode $errCode \
-errorinfo $einfo $msg
} else {
dict incr opts -level
@@ -335,7 +336,7 @@ proc unknown args {
}
}
- if {([info level] == 1) && ([info script] eq "") \
+ if {([info level] == 1) && ([info script] eq "")
&& [info exists tcl_interactive] && $tcl_interactive} {
if {![info exists auto_noexec]} {
set new [auto_execok $name]
@@ -788,7 +789,7 @@ proc tcl::CopyDirectory {action src dest} {
lappend existing {*}[glob -nocomplain -directory $dest \
-type hidden * .*]
foreach s $existing {
- if {([file tail $s] ne ".") && ([file tail $s] ne "..")} {
+ if {[file tail $s] ni {. ..}} {
return -code error "error $action \"$src\" to\
\"$dest\": file already exists"
}
@@ -796,7 +797,7 @@ proc tcl::CopyDirectory {action src dest} {
}
} else {
if {[string first $nsrc $ndest] != -1} {
- set srclen [expr {[llength [file split $nsrc]] -1}]
+ set srclen [expr {[llength [file split $nsrc]] - 1}]
set ndest [lindex [file split $ndest] $srclen]
if {$ndest eq [file tail $nsrc]} {
return -code error "error $action \"$src\" to\
@@ -816,37 +817,9 @@ proc tcl::CopyDirectory {action src dest} {
[glob -nocomplain -directory $src -types hidden *]]
foreach s [lsort -unique $filelist] {
- if {([file tail $s] ne ".") && ([file tail $s] ne "..")} {
- file copy -force $s [file join $dest [file tail $s]]
+ if {[file tail $s] ni {. ..}} {
+ file copy -force -- $s [file join $dest [file tail $s]]
}
}
return
}
-
-# TIP 131
-if 0 {
-proc tcl::rmmadwiw {} {
- set magic {
- 42 83 fe f6 ff f8 f1 e5 c6 f9 eb fd ff fb f1 e5 cc f5 ec f5 e3 fd fe
- ff f5 fa f3 e1 c7 f9 f2 fd ff f9 fe f9 ed f4 fa f6 e6 f9 f2 e6 fd f9
- ff f9 f6 e6 fa fd ff fc fb fc f9 f1 ed
- }
- foreach mystic [lassign $magic tragic] {
- set comic [expr (0x$mystic ^ 0x$tragic) - 255 + 0x$tragic]
- append logic [format %x $comic]
- set tragic $mystic
- }
- binary format H* $logic
-}
-
-proc tcl::mathfunc::rmmadwiw {} {
- set age [expr {9*6}]
- set mind ""
- while {$age} {
- lappend mind [expr {$age%13}]
- set age [expr {$age/13}]
- }
- set matter [lreverse $mind]
- return [join $matter ""]
-}
-}
diff --git a/library/package.tcl b/library/package.tcl
index c30431c..52daa0e 100644
--- a/library/package.tcl
+++ b/library/package.tcl
@@ -395,9 +395,7 @@ proc pkg_mkIndex {args} {
foreach pkg [lsort [array names files]] {
set cmd {}
- foreach {name version} $pkg {
- break
- }
+ lassign $pkg name version
lappend cmd ::tcl::Pkg::Create -name $name -version $version
foreach spec [lsort -index 0 $files($pkg)] {
foreach {file type procs} $spec {
@@ -544,8 +542,7 @@ proc tclPkgUnknown {name args} {
# Don't add directories we've already seen, or ones already on the
# $use_path.
foreach dir [lrange $auto_path $index end] {
- if {![info exists tclSeenPath($dir)]
- && ([lsearch -exact $use_path $dir] == -1) } {
+ if {![info exists tclSeenPath($dir)] && ($dir ni $use_path)} {
lappend use_path $dir
}
}
@@ -628,8 +625,7 @@ proc tcl::MacOSXPkgUnknown {original name args} {
# Don't add directories we've already seen, or ones already on the
# $use_path.
foreach dir [lrange $auto_path $index end] {
- if {![info exists tclSeenPath($dir)]
- && ([lsearch -exact $use_path $dir] == -1) } {
+ if {![info exists tclSeenPath($dir)] && ($dir ni $use_path)} {
lappend use_path $dir
}
}
@@ -681,10 +677,7 @@ proc ::tcl::Pkg::Create {args} {
}
# Initialize parameters
- set opts(-name) {}
- set opts(-version) {}
- set opts(-source) {}
- set opts(-load) {}
+ array set opts {-name {} -version {} -source {} -load {}}
# process parameters
for {set i 0} {$i < $len} {incr i} {
@@ -732,14 +725,9 @@ proc ::tcl::Pkg::Create {args} {
# Handle -load and -source specs
foreach key {load source} {
foreach filespec $opts(-$key) {
- foreach {filename proclist} {{} {}} {
- break
- }
- foreach {filename proclist} $filespec {
- break
- }
-
- if {![llength $proclist]} {
+ lassign $filespec filename proclist
+
+ if { [llength $proclist] == 0 } {
set cmd "\[list $key \[file join \$dir [list $filename]\]\]"
lappend cmdList $cmd
} else {
diff --git a/library/platform/pkgIndex.tcl b/library/platform/pkgIndex.tcl
index 220a67b..b882e4f 100644
--- a/library/platform/pkgIndex.tcl
+++ b/library/platform/pkgIndex.tcl
@@ -1,3 +1,3 @@
-package ifneeded platform 1.0.10 [list source [file join $dir platform.tcl]]
+package ifneeded platform 1.0.11 [list source [file join $dir platform.tcl]]
package ifneeded platform::shell 1.1.4 [list source [file join $dir shell.tcl]]
diff --git a/library/platform/platform.tcl b/library/platform/platform.tcl
index dd2e66b..a1a728b 100644
--- a/library/platform/platform.tcl
+++ b/library/platform/platform.tcl
@@ -256,7 +256,7 @@ proc ::platform::LibcVersion {base _->_ vv} {
if {![catch {
set vdata [lindex [split [exec $libc] \n] 0]
}]} {
- regexp {([0-9]+(\.[0-9]+)*)} $vdata -> v
+ regexp {version ([0-9]+(\.[0-9]+)*), by} $vdata -> v
foreach {major minor} [split $v .] break
set v glibc${major}.${minor}
return 1
@@ -368,7 +368,7 @@ proc ::platform::patterns {id} {
# ### ### ### ######### ######### #########
## Ready
-package provide platform 1.0.10
+package provide platform 1.0.11
# ### ### ### ######### ######### #########
## Demo application
diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl
index 83ec9d3..d6e6487 100644
--- a/library/tcltest/tcltest.tcl
+++ b/library/tcltest/tcltest.tcl
@@ -84,7 +84,7 @@ namespace eval tcltest {
# None.
#
proc normalizePath {pathVar} {
- upvar $pathVar path
+ upvar 1 $pathVar path
set oldpwd [pwd]
catch {cd $path}
set path [pwd]
@@ -247,15 +247,15 @@ namespace eval tcltest {
# Kept only for compatibility
Default constraintsSpecified {} AcceptList
- trace variable constraintsSpecified r {set ::tcltest::constraintsSpecified \
- [array names ::tcltest::testConstraints] ;# }
+ trace add variable constraintsSpecified read [namespace code {
+ set constraintsSpecified [array names testConstraints] ;#}]
# tests that use threads need to know which is the main thread
Default mainThread 1
variable mainThread
- if {[info commands thread::id] != {}} {
+ if {[info commands thread::id] ne {}} {
set mainThread [thread::id]
- } elseif {[info commands testthread] != {}} {
+ } elseif {[info commands testthread] ne {}} {
set mainThread [testthread id]
}
@@ -263,7 +263,7 @@ namespace eval tcltest {
# Tcl tests is the working directory. Whenever this value changes
# change to that directory.
variable workingDirectory
- trace variable workingDirectory w \
+ trace add variable workingDirectory write \
[namespace code {cd $workingDirectory ;#}]
Default workingDirectory [pwd] AcceptAbsolutePath
@@ -277,7 +277,7 @@ namespace eval tcltest {
# Set the location of the execuatble
Default tcltest [info nameofexecutable]
- trace variable tcltest w [namespace code {testConstraint stdio \
+ trace add variable tcltest write [namespace code {testConstraint stdio \
[eval [ConstraintInitializer stdio]] ;#}]
# save the platform information so it can be restored later
@@ -404,11 +404,11 @@ namespace eval tcltest {
# already there.
set outdir [normalizePath [file dirname \
[file join [pwd] $filename]]]
- if {[string equal $outdir [temporaryDirectory]]} {
+ if {$outdir eq [temporaryDirectory]} {
variable filesExisted
FillFilesExisted
set filename [file tail $filename]
- if {[lsearch -exact $filesExisted $filename] == -1} {
+ if {$filename ni $filesExisted} {
lappend filesExisted $filename
}
}
@@ -448,11 +448,11 @@ namespace eval tcltest {
# already there.
set outdir [normalizePath [file dirname \
[file join [pwd] $filename]]]
- if {[string equal $outdir [temporaryDirectory]]} {
+ if {$outdir eq [temporaryDirectory]} {
variable filesExisted
FillFilesExisted
set filename [file tail $filename]
- if {[lsearch -exact $filesExisted $filename] == -1} {
+ if {$filename ni $filesExisted} {
lappend filesExisted $filename
}
}
@@ -534,7 +534,7 @@ namespace eval tcltest {
}
default {
# Exact match trumps ambiguity
- if {[lsearch -exact $match $option] >= 0} {
+ if {$option in $match} {
return $option
}
set values [join [lrange $match 0 end-1] ", "]
@@ -549,7 +549,8 @@ namespace eval tcltest {
variable OptionControlledVariables
foreach varName [concat $OptionControlledVariables Option] {
variable $varName
- trace variable $varName r [namespace code {ProcessCmdLineArgs ;#}]
+ trace add variable $varName read [namespace code {
+ ProcessCmdLineArgs ;#}]
}
}
@@ -557,11 +558,11 @@ namespace eval tcltest {
variable OptionControlledVariables
foreach varName [concat $OptionControlledVariables Option] {
variable $varName
- foreach pair [trace vinfo $varName] {
- foreach {op cmd} $pair break
- if {[string equal r $op]
- && [string match *ProcessCmdLineArgs* $cmd]} {
- trace vdelete $varName $op $cmd
+ foreach pair [trace info variable $varName] {
+ lassign $pair op cmd
+ if {($op eq "read") &&
+ [string match *ProcessCmdLineArgs* $cmd]} {
+ trace remove variable $varName $op $cmd
}
}
}
@@ -698,7 +699,7 @@ namespace eval tcltest {
Option -constraints {} {
Do not skip the listed constraints listed in -constraints.
} AcceptList
- trace variable Option(-constraints) w \
+ trace add variable Option(-constraints) write \
[namespace code {SetSelectedConstraints ;#}]
# Don't run only the "-constraint" specified tests by default
@@ -707,7 +708,7 @@ namespace eval tcltest {
variable testConstraints
if {!$Option(-limitconstraints)} {return}
foreach c [array names testConstraints] {
- if {[lsearch -exact $Option(-constraints) $c] == -1} {
+ if {$c ni $Option(-constraints)} {
testConstraint $c 0
}
}
@@ -715,7 +716,7 @@ namespace eval tcltest {
Option -limitconstraints 0 {
whether to run only tests with the constraints
} AcceptBoolean limitConstraints
- trace variable Option(-limitconstraints) w \
+ trace add variable Option(-limitconstraints) write \
[namespace code {ClearUnselectedConstraints ;#}]
# A test application has to know how to load the tested commands
@@ -736,7 +737,7 @@ namespace eval tcltest {
}
set directory [AcceptDirectory $directory]
if {![file writable $directory]} {
- if {[string equal [workingDirectory] $directory]} {
+ if {[workingDirectory] eq $directory} {
# Special exception: accept the default value
# even if the directory is not writable
return $directory
@@ -750,7 +751,7 @@ namespace eval tcltest {
Option -tmpdir [workingDirectory] {
Save temporary files in the specified directory.
} AcceptTemporaryDirectory temporaryDirectory
- trace variable Option(-tmpdir) w \
+ trace add variable Option(-tmpdir) write \
[namespace code {normalizePath Option(-tmpdir) ;#}]
# Tests should not rely on the current working directory.
@@ -759,17 +760,17 @@ namespace eval tcltest {
Option -testdir [workingDirectory] {
Search tests in the specified directory.
} AcceptDirectory testsDirectory
- trace variable Option(-testdir) w \
+ trace add variable Option(-testdir) write \
[namespace code {normalizePath Option(-testdir) ;#}]
proc AcceptLoadFile { file } {
- if {[string equal "" $file]} {return $file}
+ if {$file eq {}} {return $file}
set file [file join [temporaryDirectory] $file]
return [AcceptReadable $file]
}
proc ReadLoadScript {args} {
variable Option
- if {[string equal "" $Option(-loadfile)]} {return}
+ if {$Option(-loadfile) eq {}} {return}
set tmp [open $Option(-loadfile) r]
loadScript [read $tmp]
close $tmp
@@ -777,7 +778,7 @@ namespace eval tcltest {
Option -loadfile {} {
Read the script to load the tested commands from the specified file.
} AcceptLoadFile loadFile
- trace variable Option(-loadfile) w [namespace code ReadLoadScript]
+ trace add variable Option(-loadfile) write [namespace code ReadLoadScript]
proc AcceptOutFile { file } {
if {[string equal stderr $file]} {return $file}
@@ -789,14 +790,14 @@ namespace eval tcltest {
Option -outfile stdout {
Send output from test runs to the specified file.
} AcceptOutFile outputFile
- trace variable Option(-outfile) w \
+ trace add variable Option(-outfile) write \
[namespace code {outputChannel $Option(-outfile) ;#}]
# errors go to stderr by default
Option -errfile stderr {
Send errors from test runs to the specified file.
} AcceptOutFile errorFile
- trace variable Option(-errfile) w \
+ trace add variable Option(-errfile) write \
[namespace code {errorChannel $Option(-errfile) ;#}]
proc loadIntoSlaveInterpreter {slave args} {
@@ -877,7 +878,7 @@ proc tcltest::DebugPArray {level arrayvar} {
variable debug
if {$debug >= $level} {
- catch {upvar $arrayvar $arrayvar}
+ catch {upvar 1 $arrayvar $arrayvar}
parray $arrayvar
}
return
@@ -961,8 +962,7 @@ proc tcltest::testConstraint {constraint {value ""}} {
if {[catch {expr {$value && $value}} msg]} {
return -code error $msg
}
- if {[limitConstraints]
- && [lsearch -exact $Option(-constraints) $constraint] == -1} {
+ if {[limitConstraints] && ($constraint ni $Option(-constraints))} {
set value 0
}
set testConstraints($constraint) $value
@@ -986,11 +986,7 @@ proc tcltest::interpreter { {interp ""} } {
if {[llength [info level 0]] == 1} {
return $tcltest
}
- if {[string equal {} $interp]} {
- set tcltest {}
- } else {
- set tcltest $interp
- }
+ set tcltest $interp
}
#####################################################################
@@ -1055,7 +1051,7 @@ proc tcltest::PrintError {errorMsg} {
[expr {80 - $InitialMsgLen}]]]
puts [errorChannel] [string range $errorMsg 0 $beginningIndex]
- while {![string equal end $beginningIndex]} {
+ while {$beginningIndex ne "end"} {
puts -nonewline [errorChannel] \
[string repeat " " $InitialMsgLen]
if {($endingIndex - $beginningIndex)
@@ -1108,7 +1104,7 @@ proc tcltest::PrintError {errorMsg} {
proc tcltest::SafeFetch {n1 n2 op} {
variable testConstraints
DebugPuts 3 "entering SafeFetch $n1 $n2 $op"
- if {[string equal {} $n2]} {return}
+ if {$n2 eq {}} {return}
if {![info exists testConstraints($n2)]} {
if {[catch {testConstraint $n2 [eval [ConstraintInitializer $n2]]}]} {
testConstraint $n2 0
@@ -1253,9 +1249,8 @@ proc tcltest::DefineConstraintInitializers {} {
# are running as root on Unix.
ConstraintInitializer root {expr \
- {[string equal unix $::tcl_platform(platform)]
- && ([string equal root $::tcl_platform(user)]
- || [string equal "" $::tcl_platform(user)])}}
+ {($::tcl_platform(platform) eq "unix") &&
+ ($::tcl_platform(user) in {root {}})}}
ConstraintInitializer notRoot {expr {![testConstraint root]}}
# Set nonBlockFiles constraint: 1 means this platform supports
@@ -1263,7 +1258,7 @@ proc tcltest::DefineConstraintInitializers {} {
ConstraintInitializer nonBlockFiles {
set code [expr {[catch {set f [open defs r]}]
- || [catch {fconfigure $f -blocking off}]}]
+ || [catch {chan configure $f -blocking off}]}]
catch {close $f}
set code
}
@@ -1289,10 +1284,10 @@ proc tcltest::DefineConstraintInitializers {} {
ConstraintInitializer unixExecs {
set code 1
- if {[string equal macintosh $::tcl_platform(platform)]} {
+ if {$::tcl_platform(platform) eq "macintosh"} {
set code 0
}
- if {[string equal windows $::tcl_platform(platform)]} {
+ if {$::tcl_platform(platform) eq "windows"} {
if {[catch {
set file _tcl_test_remove_me.txt
makeFile {hello} $file
@@ -1386,7 +1381,7 @@ proc tcltest::Usage { {option ""} } {
set allOpts [concat -help [Configure]]
foreach opt $allOpts {
set foo [Usage $opt]
- foreach [list x type($opt) usage($opt)] $foo break
+ lassign $foo x type($opt) usage($opt)
set line($opt) " $opt $type($opt) "
set length($opt) [string length $line($opt)]
if {$length($opt) > $max} {set max $length($opt)}
@@ -1410,7 +1405,7 @@ proc tcltest::Usage { {option ""} } {
append msg $u
}
return $msg\n
- } elseif {[string equal -help $option]} {
+ } elseif {$option eq "-help"} {
return [list -help "" "Display this usage information."]
} else {
set type [lindex [info args $Verify($option)] 0]
@@ -1436,7 +1431,7 @@ proc tcltest::Usage { {option ""} } {
proc tcltest::ProcessFlags {flagArray} {
# Process -help first
- if {[lsearch -exact $flagArray {-help}] != -1} {
+ if {"-help" in $flagArray} {
PrintUsageInfo
exit 1
}
@@ -1445,14 +1440,14 @@ proc tcltest::ProcessFlags {flagArray} {
RemoveAutoConfigureTraces
} else {
set args $flagArray
- while {[llength $args]>1 && [catch {configure {*}$args} msg]} {
+ while {[llength $args] > 1 && [catch {configure {*}$args} msg]} {
# Something went wrong parsing $args for tcltest options
# Check whether the problem is "unknown option"
if {[regexp {^unknown option (\S+):} $msg -> option]} {
# Could be this is an option the Hook knows about
set moreOptions [processCmdLineArgsAddFlagsHook]
- if {[lsearch -exact $moreOptions $option] == -1} {
+ if {$option ni $moreOptions} {
# Nope. Report the error, including additional options,
# but keep going
if {[llength $moreOptions]} {
@@ -1471,7 +1466,7 @@ proc tcltest::ProcessFlags {flagArray} {
# To recover, find that unknown option and remove up to it.
# then retry
- while {![string equal [lindex $args 0] $option]} {
+ while {[lindex $args 0] ne $option} {
set args [lrange $args 2 end]
}
set args [lrange $args 2 end]
@@ -1577,7 +1572,7 @@ proc tcltest::Replace::puts {args} {
}
2 {
# Either -nonewline or channelId has been specified
- if {[string equal -nonewline [lindex $args 0]]} {
+ if {[lindex $args 0] eq "-nonewline"} {
append outData [lindex $args end]
return
# return [Puts -nonewline [lindex $args end]]
@@ -1587,7 +1582,7 @@ proc tcltest::Replace::puts {args} {
}
}
3 {
- if {[string equal -nonewline [lindex $args 0]]} {
+ if {[lindex $args 0] eq "-nonewline"} {
# Both -nonewline and channelId are specified, unless
# it's an error. -nonewline is supposed to be argv[0].
set channel [lindex $args 1]
@@ -1597,12 +1592,10 @@ proc tcltest::Replace::puts {args} {
}
if {[info exists channel]} {
- if {[string equal $channel [[namespace parent]::outputChannel]]
- || [string equal $channel stdout]} {
+ if {$channel in [list [[namespace parent]::outputChannel] stdout]} {
append outData [lindex $args end]$newline
return
- } elseif {[string equal $channel [[namespace parent]::errorChannel]]
- || [string equal $channel stderr]} {
+ } elseif {$channel in [list [[namespace parent]::errorChannel] stderr]} {
append errData [lindex $args end]$newline
return
}
@@ -1771,7 +1764,7 @@ proc tcltest::SubstArguments {argList} {
set argList {}
}
- if {$token != {}} {
+ if {$token ne {}} {
# If we saw a word with quote before, then there is a
# multi-word token starting with that word. In this case,
# add the text and the current word to this token.
@@ -1878,10 +1871,7 @@ proc tcltest::test {name description args} {
# Pre-define everything to null except output and errorOutput. We
# determine whether or not to trap output based on whether or not
# these variables (output & errorOutput) are defined.
- foreach item {constraints setup cleanup body result returnCodes
- match} {
- set $item {}
- }
+ lassign {} constraints setup cleanup body result returnCodes match
# Set the default match mode
set match exact
@@ -1893,8 +1883,7 @@ proc tcltest::test {name description args} {
# The old test format can't have a 3rd argument (constraints or
# script) that starts with '-'.
- if {[string match -* [lindex $args 0]]
- || ([llength $args] <= 1)} {
+ if {[string match -* [lindex $args 0]] || ([llength $args] <= 1)} {
if {[llength $args] == 1} {
set list [SubstArguments [lindex $args 0]]
foreach {element value} $list {
@@ -1915,7 +1904,7 @@ proc tcltest::test {name description args} {
-match -output -errorOutput -constraints}
foreach flag [array names testAttributes] {
- if {[lsearch -exact $validFlags $flag] == -1} {
+ if {$flag ni $validFlags} {
incr testLevel -1
set sorted [lsort $validFlags]
set options [join [lrange $sorted 0 end-1] ", "]
@@ -1931,7 +1920,7 @@ proc tcltest::test {name description args} {
# Check the values supplied for -match
variable CustomMatch
- if {[lsearch [array names CustomMatch] $match] == -1} {
+ if {$match ni [array names CustomMatch]} {
incr testLevel -1
set sorted [lsort [array names CustomMatch]]
set values [join [lrange $sorted 0 end-1] ", "]
@@ -1995,7 +1984,7 @@ proc tcltest::test {name description args} {
} else {
set testResult [uplevel 1 [list [namespace origin Eval] $command 1]]
}
- foreach {actualAnswer returnCode} $testResult break
+ lassign $testResult actualAnswer returnCode
if {$returnCode == 1} {
set errorInfo(body) $::errorInfo
set errorCode(body) $::errorCode
@@ -2031,11 +2020,11 @@ proc tcltest::test {name description args} {
if {([preserveCore] > 1) && ($coreFailure)} {
append coreMsg "\nMoving file to:\
[file join [temporaryDirectory] core-$name]"
- catch {file rename -force \
+ catch {file rename -force -- \
[file join [workingDirectory] core] \
[file join [temporaryDirectory] core-$name]
} msg
- if {[string length $msg] > 0} {
+ if {$msg ne {}} {
append coreMsg "\nError:\
Problem renaming core file: $msg"
}
@@ -2045,7 +2034,7 @@ proc tcltest::test {name description args} {
# check if the return code matched the expected return code
set codeFailure 0
- if {!$setupFailure && [lsearch -exact $returnCodes $returnCode] == -1} {
+ if {!$setupFailure && ($returnCode ni $returnCodes)} {
set codeFailure 1
}
@@ -2124,7 +2113,7 @@ proc tcltest::test {name description args} {
set testFd [open $testFile r]
set testLine [expr {[lsearch -regexp \
[split [read $testFd] "\n"] \
- "^\[ \t\]*test [string map {. \\.} $name] "]+1}]
+ "^\[ \t\]*test [string map {. \\.} $name] "] + 1}]
close $testFd
}
}
@@ -2169,7 +2158,7 @@ proc tcltest::test {name description args} {
puts [outputChannel] "---- Return code should have been\
one of: $returnCodes"
if {[IsVerbose error]} {
- if {[info exists errorInfo(body)] && ([lsearch $returnCodes 1]<0)} {
+ if {[info exists errorInfo(body)] && (1 ni $returnCodes)} {
puts [outputChannel] "---- errorInfo: $errorInfo(body)"
puts [outputChannel] "---- errorCode: $errorCode(body)"
}
@@ -2250,7 +2239,7 @@ proc tcltest::Skipped {name constraints} {
}
return 1
}
- if {[string equal {} $constraints]} {
+ if {$constraints eq {}} {
# If we're limited to the listed constraints and there aren't
# any listed, then we shouldn't run the test.
if {[limitConstraints]} {
@@ -2401,7 +2390,7 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} {
foreach file $filesMade {
if {[file exists $file]} {
DebugDo 1 {Warn "cleanupTests deleting $file..."}
- catch {file delete -force $file}
+ catch {file delete -force -- $file}
}
}
set currentFiles {}
@@ -2411,7 +2400,7 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} {
}
set newFiles {}
foreach file $currentFiles {
- if {[lsearch -exact $filesExisted $file] == -1} {
+ if {$file ni $filesExisted} {
lappend newFiles $file
}
}
@@ -2494,8 +2483,7 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} {
# then add current file to failFile list if any tests in this
# file failed
- if {$currentFailure \
- && ([lsearch -exact $failFiles $testFileName] == -1)} {
+ if {$currentFailure && ($testFileName ni $failFiles)} {
lappend failFiles $testFileName
}
set currentFailure false
@@ -2555,11 +2543,11 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} {
puts [outputChannel] "produced core file! \
Moving file to: \
[file join [temporaryDirectory] core-$testFileName]"
- catch {file rename -force \
+ catch {file rename -force -- \
[file join [workingDirectory] core] \
[file join [temporaryDirectory] core-$testFileName]
} msg
- if {[string length $msg] > 0} {
+ if {$msg ne {}} {
PrintError "Problem renaming file: $msg"
}
} else {
@@ -2637,7 +2625,7 @@ proc tcltest::GetMatchingFiles { args } {
# Add to result list all files in match list and not in skip list
foreach file $matchFileList {
- if {[lsearch -exact $skipFileList $file] == -1} {
+ if {$file ni $skipFileList} {
lappend matchingFiles $file
}
}
@@ -2684,7 +2672,7 @@ proc tcltest::GetMatchingDirectories {rootdir} {
foreach pattern [matchDirectories] {
foreach path [glob -directory $rootdir -types d -nocomplain -- \
$pattern] {
- if {[lsearch -exact $skipDirs $path] == -1} {
+ if {$path ni $skipDirs} {
set matchDirs [concat $matchDirs [GetMatchingDirectories $path]]
if {[file exists [file join $path all.tcl]]} {
lappend matchDirs $path
@@ -2737,7 +2725,7 @@ proc tcltest::runAllTests { {shell ""} } {
# [file system] first available in Tcl 8.4
if {![catch {file system [testsDirectory]} result]
- && ![string equal native [lindex $result 0]]} {
+ && ([lindex $result 0] ne "native")} {
# If we aren't running in the native filesystem, then we must
# run the tests in a single process (via 'source'), because
# trying to run then via a pipe will fail since the files don't
@@ -2784,10 +2772,10 @@ proc tcltest::runAllTests { {shell ""} } {
# needs to read and process output of children.
set childargv [list]
foreach opt [Configure] {
- if {[string equal $opt -outfile]} {continue}
+ if {$opt eq "-outfile"} {continue}
set value [Configure $opt]
# Don't bother passing default configuration options
- if {[string equal $value $DefaultValue($opt)]} {
+ if {$value eq $DefaultValue($opt)} {
continue
}
lappend childargv $opt $value
@@ -2880,11 +2868,6 @@ proc tcltest::runAllTests { {shell ""} } {
# none.
proc tcltest::loadTestedCommands {} {
- variable l
- if {[string equal {} [loadScript]]} {
- return
- }
-
return [uplevel 1 [loadScript]]
}
@@ -2927,16 +2910,15 @@ proc tcltest::saveState {} {
proc tcltest::restoreState {} {
variable saveState
foreach p [uplevel 1 {::info procs}] {
- if {([lsearch [lindex $saveState 0] $p] < 0)
- && ![string equal [namespace current]::$p \
- [uplevel 1 [list ::namespace origin $p]]]} {
+ if {($p ni [lindex $saveState 0]) && ("[namespace current]::$p" ne
+ [uplevel 1 [list ::namespace origin $p]])} {
DebugPuts 2 "[lindex [info level 0] 0]: Removing proc $p"
uplevel 1 [list ::catch [list ::rename $p {}]]
}
}
foreach p [uplevel 1 {::info vars}] {
- if {[lsearch [lindex $saveState 1] $p] < 0} {
+ if {$p ni [lindex $saveState 1]} {
DebugPuts 2 "[lindex [info level 0] 0]:\
Removing variable $p"
uplevel 1 [list ::catch [list ::unset $p]]
@@ -2997,15 +2979,15 @@ proc tcltest::makeFile {contents name {directory ""}} {
putting ``$contents'' into $fullName"
set fd [open $fullName w]
- fconfigure $fd -translation lf
- if {[string equal [string index $contents end] \n]} {
+ chan configure $fd -translation lf
+ if {[string index $contents end] eq "\n"} {
puts -nonewline $fd $contents
} else {
puts $fd $contents
}
close $fd
- if {[lsearch -exact $filesMade $fullName] == -1} {
+ if {$fullName ni $filesMade} {
lappend filesMade $fullName
}
return $fullName
@@ -3045,7 +3027,7 @@ proc tcltest::removeFile {name {directory ""}} {
Warn "removeFile removing \"$fullName\":\n not a file"
}
}
- return [file delete $fullName]
+ return [file delete -- $fullName]
}
# tcltest::makeDirectory --
@@ -3075,7 +3057,7 @@ proc tcltest::makeDirectory {name {directory ""}} {
set fullName [file join $directory $name]
DebugPuts 3 "[lindex [info level 0] 0]: creating $fullName"
file mkdir $fullName
- if {[lsearch -exact $filesMade $fullName] == -1} {
+ if {$fullName ni $filesMade} {
lappend filesMade $fullName
}
return $fullName
@@ -3116,7 +3098,7 @@ proc tcltest::removeDirectory {name {directory ""}} {
Warn "removeDirectory removing \"$fullName\":\n not a directory"
}
}
- return [file delete -force $fullName]
+ return [file delete -force -- $fullName]
}
# tcltest::viewFile --
@@ -3213,7 +3195,7 @@ proc tcltest::LeakFiles {old} {
}
set leak {}
foreach p $new {
- if {[lsearch $old $p] < 0} {
+ if {$p ni $old} {
lappend leak $p
}
}
@@ -3284,7 +3266,7 @@ proc tcltest::RestoreLocale {} {
#
proc tcltest::threadReap {} {
- if {[info commands testthread] != {}} {
+ if {[info commands testthread] ne {}} {
# testthread built into tcltest
@@ -3304,7 +3286,7 @@ proc tcltest::threadReap {} {
}
testthread errorproc ThreadError
return [llength [testthread names]]
- } elseif {[info commands thread::id] != {}} {
+ } elseif {[info commands thread::id] ne {}} {
# Thread extension
@@ -3336,15 +3318,15 @@ namespace eval tcltest {
# Set up the constraints in the testConstraints array to be lazily
# initialized by a registered initializer, or by "false" if no
# initializer is registered.
- trace variable testConstraints r [namespace code SafeFetch]
+ trace add variable testConstraints read [namespace code SafeFetch]
# Only initialize constraints at package load time if an
# [initConstraintsHook] has been pre-defined. This is only
# for compatibility support. The modern way to add a custom
# test constraint is to just call the [testConstraint] command
# straight away, without all this "hook" nonsense.
- if {[string equal [namespace current] \
- [namespace qualifiers [namespace which initConstraintsHook]]]} {
+ if {[namespace current] eq
+ [namespace qualifiers [namespace which initConstraintsHook]]} {
InitConstraints
} else {
proc initConstraintsHook {} {}
@@ -3381,15 +3363,15 @@ namespace eval tcltest {
proc LoadTimeCmdLineArgParsingRequired {} {
set required false
- if {[info exists ::argv] && [lsearch -exact $::argv -help] != -1} {
+ if {[info exists ::argv] && ("-help" in $::argv)} {
# The command line asks for -help, so give it (and exit)
# right now. ([configure] does not process -help)
set required true
}
foreach hook { PrintUsageInfoHook processCmdLineArgsHook
processCmdLineArgsAddFlagsHook } {
- if {[string equal [namespace current] [namespace qualifiers \
- [namespace which $hook]]]} {
+ if {[namespace current] eq
+ [namespace qualifiers [namespace which $hook]]} {
set required true
} else {
proc $hook args {}
diff --git a/library/tm.tcl b/library/tm.tcl
index ce8a013..d2af4f5 100644
--- a/library/tm.tcl
+++ b/library/tm.tcl
@@ -54,7 +54,7 @@ namespace eval ::tcl::tm {
# Export the public API
namespace export path
- namespace ensemble create -command path -subcommand {add remove list}
+ namespace ensemble create -command path -subcommands {add remove list}
}
# ::tcl::tm::path implementations --
@@ -260,10 +260,8 @@ proc ::tcl::tm::UnknownHandler {original name args} {
# Otherwise we still have to fallback to the regular
# package search to complete the processing.
- if {
- ($pkgname eq $name) &&
- [package vsatisfies $pkgversion {*}$args]
- } then {
+ if {($pkgname eq $name)
+ && [package vsatisfies $pkgversion {*}$args]} {
set satisfied 1
# We do not abort the loop, and keep adding provide
@@ -347,7 +345,7 @@ proc ::tcl::tm::Defaults {} {
# Calls 'path add' to paths to the list of module search paths.
proc ::tcl::tm::roots {paths} {
- foreach {major minor} [split [info tclversion] .] break
+ lassign [split [package present Tcl] .] major minor
foreach pa $paths {
set p [file join $pa tcl$major]
for {set n $minor} {$n >= 0} {incr n -1} {
diff --git a/library/word.tcl b/library/word.tcl
index 16a4638..b8f34a5 100644
--- a/library/word.tcl
+++ b/library/word.tcl
@@ -67,7 +67,7 @@ namespace eval ::tcl {
proc tcl_wordBreakAfter {str start} {
variable ::tcl::WordBreakRE
set result {-1 -1}
- regexp -indices -start $start $WordBreakRE(after) $str result
+ regexp -indices -start $start -- $WordBreakRE(after) $str result
return [lindex $result 1]
}
@@ -85,7 +85,7 @@ proc tcl_wordBreakAfter {str start} {
proc tcl_wordBreakBefore {str start} {
variable ::tcl::WordBreakRE
set result {-1 -1}
- regexp -indices $WordBreakRE(before) [string range $str 0 $start] result
+ regexp -indices -- $WordBreakRE(before) [string range $str 0 $start] result
return [lindex $result 1]
}
@@ -104,7 +104,7 @@ proc tcl_wordBreakBefore {str start} {
proc tcl_endOfWord {str start} {
variable ::tcl::WordBreakRE
set result {-1 -1}
- regexp -indices -start $start $WordBreakRE(end) $str result
+ regexp -indices -start $start -- $WordBreakRE(end) $str result
return [lindex $result 1]
}
@@ -122,7 +122,7 @@ proc tcl_endOfWord {str start} {
proc tcl_startOfNextWord {str start} {
variable ::tcl::WordBreakRE
set result {-1 -1}
- regexp -indices -start $start $WordBreakRE(next) $str result
+ regexp -indices -start $start -- $WordBreakRE(next) $str result
return [lindex $result 1]
}
@@ -138,7 +138,7 @@ proc tcl_startOfNextWord {str start} {
proc tcl_startOfPreviousWord {str start} {
variable ::tcl::WordBreakRE
set word {-1 -1}
- regexp -indices $WordBreakRE(previous) [string range $str 0 $start-1] \
+ regexp -indices -- $WordBreakRE(previous) [string range $str 0 $start-1] \
result word
return [lindex $word 0]
}
diff --git a/tests/assocd.test b/tests/assocd.test
index d1489b3..b543c64 100644
--- a/tests/assocd.test
+++ b/tests/assocd.test
@@ -11,10 +11,8 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
- namespace import -force ::tcltest::*
-}
+package require tcltest 2
+namespace import ::tcltest::*
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
@@ -60,5 +58,5 @@ test assocd-3.3 {testing deleting assoc data} testdelassocdata {
} {0 {}}
# cleanup
-::tcltest::cleanupTests
+cleanupTests
return
diff --git a/tests/basic.test b/tests/basic.test
index 7435571..ccf26cc 100644
--- a/tests/basic.test
+++ b/tests/basic.test
@@ -16,7 +16,7 @@
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require tcltest 2
-namespace import -force ::tcltest::*
+namespace import ::tcltest::*
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
@@ -31,7 +31,7 @@ catch {interp delete test_interp}
catch {rename p ""}
catch {rename q ""}
catch {rename cmd ""}
-catch {unset x}
+unset -nocomplain x
test basic-1.1 {Tcl_CreateInterp, creates interp's global namespace} {
catch {interp delete test_interp}
@@ -302,7 +302,7 @@ test basic-20.1 {Tcl_GetCommandInfo, names for commands created inside namespace
catch {namespace delete {*}[namespace children :: test_ns_*]}
catch {rename p ""}
catch {rename q ""}
- catch {unset x}
+ unset -nocomplain x
set x [namespace eval test_ns_basic::test_ns_basic2 {
# the following creates a cmd in the global namespace
testcmdtoken create p
@@ -355,7 +355,7 @@ test basic-23.1 {Tcl_DeleteCommand} {emptyTest} {
test basic-24.1 {Tcl_DeleteCommandFromToken, invalidate all compiled code if cmd has compile proc} {
catch {interp delete test_interp}
- catch {unset x}
+ unset -nocomplain x
interp create test_interp
interp eval test_interp {
proc useSet {} {
@@ -427,7 +427,7 @@ test basic-26.1 {Tcl_EvalObj: preserve object while evaling it} -setup {
# string would have been freed, leaving garbage bytes for the error
# message.
set f [open $fName w]
- fileevent $f writable "fileevent $f writable {}; error foo"
+ chan event $f writable "chan event $f writable {}; error foo"
set x {}
vwait x
close $f
@@ -547,8 +547,8 @@ test basic-46.1 {Tcl_AllowExceptions: exception return not allowed} {stdio} {
catch {close $f}
set res [catch {
set f [open |[list [interpreter]] w+]
- fconfigure $f -buffering line
- puts $f {fconfigure stdout -buffering line}
+ chan configure $f -buffering line
+ puts $f {chan configure stdout -buffering line}
puts $f continue
puts $f {puts $::errorInfo}
puts $f {puts DONE}
@@ -972,6 +972,6 @@ catch {rename p ""}
catch {rename q ""}
catch {rename cmd ""}
catch {rename value:at: ""}
-catch {unset x}
-::tcltest::cleanupTests
+unset -nocomplain x
+cleanupTests
return
diff --git a/tests/cmdInfo.test b/tests/cmdInfo.test
index 69d7171..0a587e8 100644
--- a/tests/cmdInfo.test
+++ b/tests/cmdInfo.test
@@ -13,10 +13,8 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest 2
- namespace import -force ::tcltest::*
-}
+package require tcltest 2
+namespace import ::tcltest::*
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
@@ -101,7 +99,7 @@ test cmdinfo-6.1 {Names for commands created when outside namespaces} \
# cleanup
catch {namespace delete cmdInfoNs1::cmdInfoNs2 cmdInfoNs1}
catch {rename x1 ""}
-::tcltest::cleanupTests
+cleanupTests
return
# Local Variables:
diff --git a/tests/dcall.test b/tests/dcall.test
index 3df0ac8..41dd777 100644
--- a/tests/dcall.test
+++ b/tests/dcall.test
@@ -11,10 +11,8 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
- namespace import -force ::tcltest::*
-}
+package require tcltest 2
+namespace import ::tcltest::*
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
@@ -41,5 +39,5 @@ test dcall-1.6 {deletion callbacks} testdcall {
} {}
# cleanup
-::tcltest::cleanupTests
+cleanupTests
return
diff --git a/tests/expr-old.test b/tests/expr-old.test
index 4f3cb2e..06a00ba 100644
--- a/tests/expr-old.test
+++ b/tests/expr-old.test
@@ -13,10 +13,8 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest 2.1
- namespace import -force ::tcltest::*
-}
+package require tcltest 2.1
+namespace import ::tcltest::*
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
@@ -145,7 +143,7 @@ test expr-old-1.50 {integer operators} {expr +36} 36
test expr-old-1.51 {integer operators} {expr +--++36} 36
test expr-old-1.52 {integer operators} {expr +36%+5} 1
test expr-old-1.53 {integer operators} {
- catch {unset x}
+ unset -nocomplain x
set x yes
list [expr {1 && $x}] [expr {$x && 1}] \
[expr {0 || $x}] [expr {$x || 0}]
@@ -453,7 +451,7 @@ test expr-old-23.3 {double quotes} {
test expr-old-23.4 {double quotes} {expr {"11\}\}22"}} 11}}22
test expr-old-23.5 {double quotes} {expr {"\*bc"}} {*bc}
test expr-old-23.6 {double quotes} {
- catch {unset bogus__}
+ unset -nocomplain bogus__
list [catch {expr {"$bogus__"}} msg] $msg
} {1 {can't read "bogus__": no such variable}}
test expr-old-23.7 {double quotes} {
@@ -502,7 +500,7 @@ test expr-old-26.2 {error conditions} -body {
test expr-old-26.3 {error conditions} -body {
expr 2+4*(
} -returnCodes error -match glob -result *
-catch {unset _non_existent_}
+unset -nocomplain _non_existent_
test expr-old-26.4 {error conditions} {
list [catch {expr 2+$_non_existent_} msg] $msg
} {1 {can't read "_non_existent_": no such variable}}
@@ -581,7 +579,7 @@ test expr-old-27.4 {cancelled evaluation} {
expr {1?2:[set a 2]}
set a
} 1
-catch {unset x}
+unset -nocomplain x
test expr-old-27.5 {cancelled evaluation} {
list [catch {expr {[info exists x] && $x}} msg] $msg
} {0 0}
diff --git a/tests/main.test b/tests/main.test
index f1dc7fd..351fd4f 100644
--- a/tests/main.test
+++ b/tests/main.test
@@ -129,7 +129,7 @@ namespace eval ::tcl::test::main {
set script [makeFile {} script]
file delete $script
set f [open $script w]
- fconfigure $f -encoding utf-8
+ chan configure $f -encoding utf-8
puts $f {puts [list $argv0 $argv $tcl_interactive]}
puts -nonewline $f {puts [string equal \u20ac }
puts $f "\u20ac]"
@@ -150,7 +150,7 @@ namespace eval ::tcl::test::main {
set script [makeFile {} script]
file delete $script
set f [open $script w]
- fconfigure $f -encoding utf-8
+ chan configure $f -encoding utf-8
puts $f {puts [list $argv0 $argv $tcl_interactive]}
puts -nonewline $f {puts [string equal \u20ac }
puts $f "\u20ac]"
@@ -171,7 +171,7 @@ namespace eval ::tcl::test::main {
set script [makeFile {} script]
file delete $script
set f [open $script w]
- fconfigure $f -encoding utf-8
+ chan configure $f -encoding utf-8
puts $f {puts [list $argv0 $argv $tcl_interactive]}
puts -nonewline $f {puts [string equal \u20ac }
puts $f "\u20ac]"
@@ -592,7 +592,7 @@ namespace eval ::tcl::test::main {
catch {set f [open "|[list [interpreter]]" w+]}
} -body {
type $f {
- fconfigure stdin -blocking 0
+ chan configure stdin -blocking 0
puts SUCCESS
}
list [catch {gets $f} line] $line
@@ -606,19 +606,19 @@ namespace eval ::tcl::test::main {
exec
} -setup {
catch {set f [open "|[list [interpreter]]" w+]}
- catch {fconfigure $f -blocking 0}
+ catch {chan configure $f -blocking 0}
} -body {
- type $f "fconfigure stdin -eofchar \\032
+ type $f "chan configure stdin -eofchar \\032
if 1 \{\n\032"
variable wait
- fileevent $f readable \
+ chan event $f readable \
[list set [namespace which -variable wait] "child exit"]
set id [after 2000 [list set [namespace which -variable wait] timeout]]
vwait [namespace which -variable wait]
after cancel $id
set wait
} -cleanup {
- if {[string equal timeout $wait] && [testConstraint unix]} {
+ if {$wait eq "timeout" && [testConstraint unix]} {
exec kill [pid $f]
}
close $f
@@ -631,17 +631,17 @@ namespace eval ::tcl::test::main {
} -setup {
set cmd {makeFile "if 1 \{" script}
catch {set f [open "|[list [interpreter]] < [list [eval $cmd]]" r]}
- catch {fconfigure $f -blocking 0}
+ catch {chan configure $f -blocking 0}
} -body {
variable wait
- fileevent $f readable \
+ chan event $f readable \
[list set [namespace which -variable wait] "child exit"]
set id [after 2000 [list set [namespace which -variable wait] timeout]]
vwait [namespace which -variable wait]
after cancel $id
set wait
} -cleanup {
- if {[string equal timeout $wait] && [testConstraint unix]} {
+ if {$wait eq "timeout" && [testConstraint unix]} {
exec kill [pid $f]
}
close $f
@@ -748,7 +748,7 @@ namespace eval ::tcl::test::main {
exec Tcltest
} -setup {
catch {set f [open "|[list [interpreter]]" w+]}
- catch {fconfigure $f -blocking 0}
+ catch {chan configure $f -blocking 0}
} -body {
type $f "testsetmainloop
after 2000 testexitmainloop
@@ -983,7 +983,7 @@ namespace eval ::tcl::test::main {
} -body {
exec [interpreter] << {
testsetmainloop
- fconfigure stdin -blocking 0
+ chan configure stdin -blocking 0
testexitmainloop
} >& result
set f [open result]
diff --git a/tests/msgcat.test b/tests/msgcat.test
index 1522354..70a7af2 100644
--- a/tests/msgcat.test
+++ b/tests/msgcat.test
@@ -12,7 +12,7 @@
# Note that after running these tests, entries will be left behind in the
# message catalogs for locales foo, foo_BAR, and foo_BAR_baz.
-package require Tcl 8.2
+package require Tcl 8.5
if {[catch {package require tcltest 2}]} {
puts stderr "Skipping tests in [info script]. tcltest 2 required."
return
@@ -56,7 +56,7 @@ namespace eval ::msgcat::test {
set result [string tolower \
[msgcat::ConvertLocale $::tcl::mac::locale]]
} else {
- if {([info sharedlibextension] == ".dll")
+ if {([info sharedlibextension] eq ".dll")
&& ![catch {package require registry}]} {
# Windows and Cygwin have other ways to determine the
# locale when the environment variables are missing
@@ -72,7 +72,7 @@ namespace eval ::msgcat::test {
variable var
foreach var $envVars {
catch {variable $var $::env($var)}
- catch {unset ::env($var)}
+ unset -nocomplain ::env($var)
}
foreach var $setVars {
set ::env($var) $var
@@ -84,13 +84,13 @@ namespace eval ::msgcat::test {
} -cleanup {
interp delete [namespace current]::i
foreach var $envVars {
- catch {unset ::env($var)}
+ unset -nocomplain ::env($var)
catch {set ::env($var) [set [namespace current]::$var]}
}
} -body {i eval msgcat::mclocale} -result $result
incr count
}
- catch {unset result}
+ unset -nocomplain result
# Could add tests of initialization from Windows registry here.
# Use a fake registry package.
@@ -324,7 +324,7 @@ namespace eval ::msgcat::test {
incr count
}
}
- catch {unset result}
+ unset -nocomplain result
# Tests msgcat-4.*: [mcunknown]
diff --git a/tests/parse.test b/tests/parse.test
index bc4107d..b9cfe80 100644
--- a/tests/parse.test
+++ b/tests/parse.test
@@ -439,7 +439,7 @@ test parse-8.12 {Tcl_EvalObjv procedure, TCL_EVAL_INVOKE} {
test parse-9.1 {Tcl_LogCommandInfo, line numbers} testevalex {
- catch {unset x}
+ unset -nocomplain x
list [catch {testevalex {for {} 1 {} {
@@ -480,7 +480,7 @@ test parse-10.3 {Tcl_EvalTokens, nested commands} testevalex {
testevalex {concat [expr 2 + 6]}
} {8}
test parse-10.4 {Tcl_EvalTokens, nested commands} testevalex {
- catch {unset a}
+ unset -nocomplain a
list [catch {testevalex {concat xxx[expr $a]}} msg] $msg
} {1 {can't read "a": no such variable}}
test parse-10.5 {Tcl_EvalTokens, simple variables} testevalex {
@@ -488,21 +488,21 @@ test parse-10.5 {Tcl_EvalTokens, simple variables} testevalex {
testevalex {concat $a}
} {hello}
test parse-10.6 {Tcl_EvalTokens, array variables} testevalex {
- catch {unset a}
+ unset -nocomplain a
set a(12) 46
testevalex {concat $a(12)}
} {46}
test parse-10.7 {Tcl_EvalTokens, array variables} testevalex {
- catch {unset a}
+ unset -nocomplain a
set a(12) 46
testevalex {concat $a(1[expr 3 - 1])}
} {46}
test parse-10.8 {Tcl_EvalTokens, array variables} testevalex {
- catch {unset a}
+ unset -nocomplain a
list [catch {testevalex {concat $x($a)}} msg] $msg
} {1 {can't read "a": no such variable}}
test parse-10.9 {Tcl_EvalTokens, array variables} testevalex {
- catch {unset a}
+ unset -nocomplain a
list [catch {testevalex {concat xyz$a(1)}} msg] $msg
} {1 {can't read "a(1)": no such variable}}
test parse-10.10 {Tcl_EvalTokens, object values} testevalex {
@@ -542,11 +542,11 @@ test parse-11.2 {Tcl_EvalEx, error while parsing} testevalex {
list [catch {testevalex {concat "abc}} msg] $msg
} {1 {missing "}}
test parse-11.3 {Tcl_EvalEx, error while collecting words} testevalex {
- catch {unset a}
+ unset -nocomplain a
list [catch {testevalex {concat xyz $a}} msg] $msg
} {1 {can't read "a": no such variable}}
test parse-11.4 {Tcl_EvalEx, error in Tcl_EvalObjv call} testevalex {
- catch {unset a}
+ unset -nocomplain a
list [catch {testevalex {_bogus_ a b c d}} msg] $msg
} {1 {invalid command name "_bogus_"}}
test parse-11.5 {Tcl_EvalEx, exceptional return} testevalex {
@@ -565,7 +565,7 @@ test parse-11.8 {Tcl_EvalEx, multiple commands in script} testevalex {
}] $a $c
} {d b d}
test parse-11.9 {Tcl_EvalEx, freeing memory after error} testevalex {
- catch {unset a}
+ unset -nocomplain a
list [catch {testevalex {concat a b c d e f g h i j k l m n o p q r s t u v w x y z $a}} msg] $msg
} {1 {can't read "a": no such variable}}
test parse-11.10 {Tcl_EvalTokens, empty commands} testevalex {
@@ -671,11 +671,11 @@ test parse-13.3 {Tcl_ParseVar procedure, no variable name} testparsevar {
testparsevar {$.123}
} {{$} .123}
test parse-13.4 {Tcl_ParseVar procedure, error looking up variable} testparsevar {
- catch {unset abc}
+ unset -nocomplain abc
list [catch {testparsevar {$abc}} msg] $msg
} {1 {can't read "abc": no such variable}}
test parse-13.5 {Tcl_ParseVar procedure, error looking up variable} testparsevar {
- catch {unset abc}
+ unset -nocomplain abc
list [catch {testparsevar {$abc([bogus x y z])}} msg] $msg
} {1 {invalid command name "bogus"}}
@@ -1092,13 +1092,12 @@ test parse-20.12 {TclParseBackslash: truncated escape} testparser {
} {- {\x12X} 1 word {\x12X} 2 backslash {\x12} 0 text X 0 {}}
test parse-21.0 {Bug 1884496} testevent {
- set ::script {set a [p]; return -level 0 $a}
+ set ::script {testevent delete a; set a [p]; set ::done $a}
proc ::p {} {string first s $::script}
testevent queue a head $::script
- update
+ vwait done
} {}
-
cleanupTests
}
diff --git a/tests/parseExpr.test b/tests/parseExpr.test
index 7910974..714c45b 100644
--- a/tests/parseExpr.test
+++ b/tests/parseExpr.test
@@ -8,10 +8,8 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest 2
- namespace import -force ::tcltest::*
-}
+package require tcltest 2
+namespace import ::tcltest::*
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
@@ -1067,5 +1065,5 @@ test parseExpr-22.18 {Bug 3401704} -constraints testexprparser -body {
# cleanup
-::tcltest::cleanupTests
+cleanupTests
return
diff --git a/tests/parseOld.test b/tests/parseOld.test
index 0edcbf0..f3b1591 100644
--- a/tests/parseOld.test
+++ b/tests/parseOld.test
@@ -13,10 +13,8 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
- namespace import -force ::tcltest::*
-}
+package require tcltest
+namespace import ::tcltest::*
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
@@ -166,25 +164,25 @@ test parseOld-5.6 {variable substitution} {
set msg
} {can't read "_non_existent_": no such variable}
test parseOld-5.7 {array variable substitution} {
- catch {unset a}
+ unset -nocomplain a
set a(xyz) 123
set b $a(xyz)foo
set b
} 123foo
test parseOld-5.8 {array variable substitution} {
- catch {unset a}
+ unset -nocomplain a
set "a(x y z)" 123
set b $a(x y z)foo
set b
} 123foo
test parseOld-5.9 {array variable substitution} {
- catch {unset a}; catch {unset qqq}
+ unset -nocomplain a qqq
set "a(x y z)" qqq
set $a([format x]\ y [format z]) foo
set qqq
} foo
test parseOld-5.10 {array variable substitution} {
- catch {unset a}
+ unset -nocomplain a
list [catch {set b $a(22)} msg] $msg
} {1 {can't read "a(22)": no such variable}}
test parseOld-5.11 {array variable substitution} {
@@ -194,9 +192,9 @@ test parseOld-5.11 {array variable substitution} {
test parseOld-5.12 {empty array name support} {
list [catch {set b a$()} msg] $msg
} {1 {can't read "()": no such variable}}
-catch {unset a}
+unset -nocomplain a
test parseOld-5.13 {array variable substitution} {
- catch {unset a}
+ unset -nocomplain a
set long {This is a very long variable, long enough to cause storage \
allocation to occur in Tcl_ParseVar. If that storage isn't getting \
freed up correctly, then a core leak will occur when this test is \
@@ -211,13 +209,13 @@ test parseOld-5.13 {array variable substitution} {
run. This text is probably beginning to sound like drivel, but I've \
run out of things to say and I need more characters still.}}}
test parseOld-5.14 {array variable substitution} {
- catch {unset a}; catch {unset b}; catch {unset a1}
+ unset -nocomplain a b a1
set a1(22) foo
set a(foo) bar
set b $a($a1(22))
set b
} bar
-catch {unset a}; catch {unset a1}
+unset -nocomplain a a1
test parseOld-7.1 {backslash substitution} {
set a "\a\c\n\]\}"
diff --git a/tests/pkgMkIndex.test b/tests/pkgMkIndex.test
index 0fe394e..84c82ce 100644
--- a/tests/pkgMkIndex.test
+++ b/tests/pkgMkIndex.test
@@ -8,10 +8,8 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest 2
- namespace import -force ::tcltest::*
-}
+package require tcltest 2
+namespace import ::tcltest::*
set fullPkgPath [makeDirectory pkg]
@@ -45,7 +43,7 @@ proc pkgtest::parseArgs { args } {
set a [lindex $args $iarg]
if {[regexp {^-} $a]} {
lappend options $a
- if {[string compare -load $a] == 0} {
+ if {$a eq "-load"} {
incr iarg
lappend options [lindex $args $iarg]
}
@@ -81,7 +79,7 @@ proc pkgtest::parseIndex { filePath } {
$slave eval {
rename package package_original
proc package { args } {
- if {[string compare [lindex $args 0] ifneeded] == 0} {
+ if {[lindex $args 0] eq "ifneeded"} {
set pkg [lindex $args 1]
set ver [lindex $args 2]
set ::PKGS($pkg:$ver) [lindex $args 3]
@@ -111,9 +109,9 @@ proc pkgtest::parseIndex { filePath } {
foreach k [lsort [array names P]] {
lappend PKGS $k $P($k)
}
- } err]} {
- set ei $::errorInfo
- set ec $::errorCode
+ } err opts]} {
+ set ei [dict get $opts -errorinfo]
+ set ec [dict get $opts -errorcode]
catch {interp delete $slave}
diff --git a/tests/platform.test b/tests/platform.test
index aab7c78..6596975 100644
--- a/tests/platform.test
+++ b/tests/platform.test
@@ -9,10 +9,14 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
- namespace import -force ::tcltest::*
-}
+package require tcltest 2
+
+namespace eval ::tcl::test::platform {
+ namespace import ::tcltest::testConstraint
+ namespace import ::tcltest::test
+ namespace import ::tcltest::cleanupTests
+
+ variable ::tcl_platform
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
@@ -54,7 +58,10 @@ test platform-3.1 {CPU ID on Windows/UNIX} \
-result {^(?:AuthenticAMD|CentaurHauls|CyrixInstead|GenuineIntel)$}
# cleanup
-::tcltest::cleanupTests
+cleanupTests
+
+}
+namespace delete ::tcl::test::platform
return
# Local Variables:
diff --git a/tests/result.test b/tests/result.test
index 3391ce1..9e8a66b 100644
--- a/tests/result.test
+++ b/tests/result.test
@@ -10,10 +10,8 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest 2
- namespace import -force ::tcltest::*
-}
+package require tcltest 2
+namespace import ::tcltest::*
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
diff --git a/tests/stack.test b/tests/stack.test
index 873cb08..13bc524 100644
--- a/tests/stack.test
+++ b/tests/stack.test
@@ -9,10 +9,8 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest 2
- namespace import -force ::tcltest::*
-}
+package require tcltest 2
+namespace import ::tcltest::*
# Note that a failure in this test may result in a crash of the executable.
diff --git a/tests/tcltest.test b/tests/tcltest.test
index 86aca6f..ce8d617 100755
--- a/tests/tcltest.test
+++ b/tests/tcltest.test
@@ -80,10 +80,7 @@ proc slave {msgVar args} {
# Need to capture output in msg
- set code [catch {i eval {source $argv0}} foo]
-if $code {
-#puts "$code: $foo\n$::errorInfo"
-}
+ set code [catch {i eval {source $argv0}}]
i eval {close $tcltest::outputChannel}
interp delete [namespace current]::i
set f [open $of]
@@ -99,8 +96,6 @@ if $code {
append msg \n$err
}
return $code
-
-# return [catch {uplevel 1 [linsert $args 0 exec [interpreter]]} msg]
}
test tcltest-2.0 {tcltest (verbose default - 'b')} {unixOrPc} {
set result [slave msg test.tcl]
@@ -549,7 +544,7 @@ set notWriteableDir [file join [temporaryDirectory] notwriteable]
makeDirectory notreadable
makeDirectory notwriteable
switch -- $::tcl_platform(platform) {
- "unix" {
+ unix {
file attributes $notReadableDir -permissions 00333
file attributes $notWriteableDir -permissions 00555
}
@@ -716,8 +711,8 @@ test tcltest-8.60 {::workingDirectory} {
# clean up from directory testing
-switch $::tcl_platform(platform) {
- "unix" {
+switch -- $::tcl_platform(platform) {
+ unix {
file attributes $notReadableDir -permissions 777
file attributes $notWriteableDir -permissions 777
}
@@ -727,7 +722,7 @@ switch $::tcl_platform(platform) {
}
}
-file delete -force $notReadableDir $notWriteableDir
+file delete -force -- $notReadableDir $notWriteableDir
removeFile a.tcl
removeFile thisdirectoryisafile
removeDirectory normaldirectory
@@ -1150,7 +1145,7 @@ test tcltest-19.1 {TCLTEST_OPTIONS default} -setup {
} -cleanup {
interp delete slave2
interp delete slave1
- if {$oldoptions == "none"} {
+ if {$oldoptions eq "none"} {
unset ::env(TCLTEST_OPTIONS)
} else {
set ::env(TCLTEST_OPTIONS) $oldoptions
diff --git a/tests/thread.test b/tests/thread.test
index d79f693..f32ef61 100644
--- a/tests/thread.test
+++ b/tests/thread.test
@@ -84,28 +84,6 @@ if {[testConstraint testthread]} {
}
testthread errorproc ThreadError
-
- set mainThread [testthread id]
-
- proc ThreadNullError {id info} {
- # ignore
- }
-
- proc threadReap {} {
- testthread errorproc ThreadNullError
- while {[llength [testthread names]] > 1} {
- foreach tid [testthread names] {
- if {$tid != [testthread id]} {
- catch {
- testthread send -async $tid {testthread exit}
- }
- }
- }
- after 1
- }
- testthread errorproc ThreadError
- return [llength [testthread names]]
- }
}
# Some tests require manual draining of the event queue
diff --git a/tests/tm.test b/tests/tm.test
index 149a65d..1b22f8c 100644
--- a/tests/tm.test
+++ b/tests/tm.test
@@ -200,7 +200,7 @@ test tm-3.11 {tm: module path management, remove ignores unknown path} -setup {
proc genpaths {base} {
# Normalizing picks up drive letters on windows [Bug 1053568]
set base [file normalize $base]
- foreach {major minor} [split [info tclversion] .] break
+ lassign [split [package present Tcl] .] major minor
set results {}
set base [file join $base tcl$major]
lappend results [file join $base site-tcl]
diff --git a/tests/trace.test b/tests/trace.test
index 0f48dcf..b4957c0 100644
--- a/tests/trace.test
+++ b/tests/trace.test
@@ -11,10 +11,8 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
- namespace import -force ::tcltest::*
-}
+package require tcltest
+namespace import ::tcltest::*
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
@@ -32,15 +30,15 @@ proc getbytes {} {
proc traceScalar {name1 name2 op} {
global info
- set info [list $name1 $name2 $op [catch {uplevel set $name1} msg] $msg]
+ set info [list $name1 $name2 $op [catch {uplevel 1 set $name1} msg] $msg]
}
proc traceScalarAppend {name1 name2 op} {
global info
- lappend info $name1 $name2 $op [catch {uplevel set $name1} msg] $msg
+ lappend info $name1 $name2 $op [catch {uplevel 1 set $name1} msg] $msg
}
proc traceArray {name1 name2 op} {
global info
- set info [list $name1 $name2 $op [catch {uplevel set [set name1]($name2)} msg] $msg]
+ set info [list $name1 $name2 $op [catch {uplevel 1 set [set name1]($name2)} msg] $msg]
}
proc traceArray2 {name1 name2 op} {
global info
@@ -62,7 +60,7 @@ proc traceCheck {cmd args} {
set info [list [catch $cmd msg] $msg]
}
proc traceCrtElement {value name1 name2 op} {
- uplevel set ${name1}($name2) $value
+ uplevel 1 set ${name1}($name2) $value
}
proc traceCommand {oldName newName op} {
global info
@@ -72,10 +70,10 @@ proc traceCommand {oldName newName op} {
test trace-0.0 {memory corruption in trace (Tcl Bug 484339)} {
# You may need Purify or Electric Fence to reliably
# see this one fail.
- catch {unset z}
+ unset -nocomplain z
trace add variable z array {set z(foo) 1 ;#}
set res "names: [array names z]"
- catch {unset ::z}
+ unset -nocomplain ::z
trace variable ::z w {unset ::z; error "memory corruption";#}
list [catch {set ::z 1} msg] $msg
} {1 {can't set "::z": memory corruption}}
@@ -83,40 +81,40 @@ test trace-0.0 {memory corruption in trace (Tcl Bug 484339)} {
# Read-tracing on variables
test trace-1.1 {trace variable reads} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x read traceScalar
list [catch {set x} msg] $msg $info
} {1 {can't read "x": no such variable} {x {} read 1 {can't read "x": no such variable}}}
test trace-1.2 {trace variable reads} {
- catch {unset x}
+ unset -nocomplain x
set x 123
set info {}
trace add variable x read traceScalar
list [catch {set x} msg] $msg $info
} {0 123 {x {} read 0 123}}
test trace-1.3 {trace variable reads} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x read traceScalar
set x 123
set info
} {}
test trace-1.4 {trace array element reads} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x(2) read traceArray
list [catch {set x(2)} msg] $msg $info
} {1 {can't read "x(2)": no such element in array} {x 2 read 1 {can't read "x(2)": no such element in array}}}
test trace-1.5 {trace array element reads} {
- catch {unset x}
+ unset -nocomplain x
set x(2) zzz
set info {}
trace add variable x(2) read traceArray
list [catch {set x(2)} msg] $msg $info
} {0 zzz {x 2 read 0 zzz}}
test trace-1.6 {trace array element reads} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x read traceArray2
proc p {} {
@@ -127,7 +125,7 @@ test trace-1.6 {trace array element reads} {
list [catch {p} msg] $msg $info
} {0 willi {x 2 read}}
test trace-1.7 {trace array element reads, create element undefined if nonexistant} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x read q
proc q {name1 name2 op} {
@@ -144,20 +142,20 @@ test trace-1.7 {trace array element reads, create element undefined if nonexista
list [catch {p} msg] $msg $info
} {0 wolf {x Y read}}
test trace-1.8 {trace reads on whole arrays} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x read traceArray
list [catch {set x(2)} msg] $msg $info
} {1 {can't read "x(2)": no such variable} {}}
test trace-1.9 {trace reads on whole arrays} {
- catch {unset x}
+ unset -nocomplain x
set x(2) zzz
set info {}
trace add variable x read traceArray
list [catch {set x(2)} msg] $msg $info
} {0 zzz {x 2 read 0 zzz}}
test trace-1.10 {trace variable reads} {
- catch {unset x}
+ unset -nocomplain x
set x 444
set info {}
trace add variable x read traceScalar
@@ -165,28 +163,28 @@ test trace-1.10 {trace variable reads} {
set info
} {}
test trace-1.11 {read traces that modify the array structure} {
- catch {unset x}
+ unset -nocomplain x
set x(bar) 0
trace variable x r {set x(foo) 1 ;#}
trace variable x r {unset -nocomplain x(bar) ;#}
array get x
} {}
test trace-1.12 {read traces that modify the array structure} {
- catch {unset x}
+ unset -nocomplain x
set x(bar) 0
trace variable x r {unset -nocomplain x(bar) ;#}
trace variable x r {set x(foo) 1 ;#}
array get x
} {}
test trace-1.13 {read traces that modify the array structure} {
- catch {unset x}
+ unset -nocomplain x
set x(bar) 0
trace variable x r {set x(foo) 1 ;#}
trace variable x r {unset -nocomplain x;#}
list [catch {array get x} res] $res
} {1 {can't read "x(bar)": no such variable}}
test trace-1.14 {read traces that modify the array structure} {
- catch {unset x}
+ unset -nocomplain x
set x(bar) 0
trace variable x r {unset -nocomplain x;#}
trace variable x r {set x(foo) 1 ;#}
@@ -196,28 +194,28 @@ test trace-1.14 {read traces that modify the array structure} {
# Basic write-tracing on variables
test trace-2.1 {trace variable writes} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x write traceScalar
set x 123
set info
} {x {} write 0 123}
test trace-2.2 {trace writes to array elements} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x(33) write traceArray
set x(33) 444
set info
} {x 33 write 0 444}
test trace-2.3 {trace writes on whole arrays} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x write traceArray
set x(abc) qq
set info
} {x abc write 0 qq}
test trace-2.4 {trace variable writes} {
- catch {unset x}
+ unset -nocomplain x
set x 1234
set info {}
trace add variable x write traceScalar
@@ -225,7 +223,7 @@ test trace-2.4 {trace variable writes} {
set info
} {}
test trace-2.5 {trace variable writes} {
- catch {unset x}
+ unset -nocomplain x
set x 1234
set info {}
trace add variable x write traceScalar
@@ -238,7 +236,7 @@ test trace-2.6 {trace variable writes on compiled local} {
# arrays [Bug 1770591]. The corresponding function for read traces is
# already indirectly tested in trace-1.7
#
- catch {unset x}
+ unset -nocomplain x
set info {}
proc p {} {
trace add variable x write traceArray
@@ -267,7 +265,7 @@ test trace-2.7 {trace variable writes on errorInfo} -body {
# trace: after appending all arguments to the list.
test trace-3.1 {trace variable read-modify-writes} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x read traceScalarAppend
append x 123
@@ -276,7 +274,7 @@ test trace-3.1 {trace variable read-modify-writes} {
set info
} {x {} read 0 123456}
test trace-3.2 {trace variable read-modify-writes} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x {read write} traceScalarAppend
append x 123
@@ -287,14 +285,14 @@ test trace-3.2 {trace variable read-modify-writes} {
# Basic unset-tracing on variables
test trace-4.1 {trace variable unsets} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x unset traceScalar
- catch {unset x}
+ unset -nocomplain x
set info
} {x {} unset 1 {can't read "x": no such variable}}
test trace-4.2 {variable mustn't exist during unset trace} {
- catch {unset x}
+ unset -nocomplain x
set x 1234
set info {}
trace add variable x unset traceScalar
@@ -302,7 +300,7 @@ test trace-4.2 {variable mustn't exist during unset trace} {
set info
} {x {} unset 1 {can't read "x": no such variable}}
test trace-4.3 {unset traces mustn't be called during reads and writes} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x unset traceScalar
set x 44
@@ -310,15 +308,15 @@ test trace-4.3 {unset traces mustn't be called during reads and writes} {
set info
} {}
test trace-4.4 {trace unsets on array elements} {
- catch {unset x}
+ unset -nocomplain x
set x(0) 18
set info {}
trace add variable x(1) unset traceArray
- catch {unset x(1)}
+ unset -nocomplain x(1)
set info
} {x 1 unset 1 {can't read "x(1)": no such element in array}}
test trace-4.5 {trace unsets on array elements} {
- catch {unset x}
+ unset -nocomplain x
set x(1) 18
set info {}
trace add variable x(1) unset traceArray
@@ -326,7 +324,7 @@ test trace-4.5 {trace unsets on array elements} {
set info
} {x 1 unset 1 {can't read "x(1)": no such element in array}}
test trace-4.6 {trace unsets on array elements} {
- catch {unset x}
+ unset -nocomplain x
set x(1) 18
set info {}
trace add variable x(1) unset traceArray
@@ -334,15 +332,15 @@ test trace-4.6 {trace unsets on array elements} {
set info
} {x 1 unset 1 {can't read "x(1)": no such variable}}
test trace-4.7 {trace unsets on whole arrays} {
- catch {unset x}
+ unset -nocomplain x
set x(1) 18
set info {}
trace add variable x unset traceProc
- catch {unset x(0)}
+ unset -nocomplain x(0)
set info
} {}
test trace-4.8 {trace unsets on whole arrays} {
- catch {unset x}
+ unset -nocomplain x
set x(1) 18
set x(2) 144
set x(3) 14
@@ -352,7 +350,7 @@ test trace-4.8 {trace unsets on whole arrays} {
set info
} {x 1 unset}
test trace-4.9 {trace unsets on whole arrays} {
- catch {unset x}
+ unset -nocomplain x
set x(1) 18
set x(2) 144
set x(3) 14
@@ -364,7 +362,7 @@ test trace-4.9 {trace unsets on whole arrays} {
# Array tracing on variables
test trace-5.1 {array traces fire on accesses via [array]} {
- catch {unset x}
+ unset -nocomplain x
set x(b) 2
trace add variable x array traceArray2
set ::info {}
@@ -372,7 +370,7 @@ test trace-5.1 {array traces fire on accesses via [array]} {
set ::info
} {x {} array}
test trace-5.2 {array traces do not fire on normal accesses} {
- catch {unset x}
+ unset -nocomplain x
set x(b) 2
trace add variable x array traceArray2
set ::info {}
@@ -381,7 +379,7 @@ test trace-5.2 {array traces do not fire on normal accesses} {
set ::info
} {}
test trace-5.3 {array traces do not outlive variable} {
- catch {unset x}
+ unset -nocomplain x
trace add variable x array traceArray2
set ::info {}
set x(a) 1
@@ -390,19 +388,19 @@ test trace-5.3 {array traces do not outlive variable} {
set ::info
} {}
test trace-5.4 {array traces properly listed in trace information} {
- catch {unset x}
+ unset -nocomplain x
trace add variable x array traceArray2
set result [trace info variable x]
set result
} [list [list array traceArray2]]
test trace-5.5 {array traces properly listed in trace information} {
- catch {unset x}
+ unset -nocomplain x
trace variable x a traceArray2
set result [trace vinfo x]
set result
} [list [list a traceArray2]]
test trace-5.6 {array traces don't fire on scalar variables} {
- catch {unset x}
+ unset -nocomplain x
set x foo
trace add variable x array traceArray2
set ::info {}
@@ -410,14 +408,14 @@ test trace-5.6 {array traces don't fire on scalar variables} {
set ::info
} {}
test trace-5.7 {array traces fire for undefined variables} {
- catch {unset x}
+ unset -nocomplain x
trace add variable x array traceArray2
set ::info {}
array set x {a 1}
set ::info
} {x {} array}
test trace-5.8 {array traces fire for undefined variables} {
- catch {unset x}
+ unset -nocomplain x
trace add variable x array {set x(foo) 1 ;#}
set res "names: [array names x]"
} {names: foo}
@@ -425,7 +423,7 @@ test trace-5.8 {array traces fire for undefined variables} {
# Trace multiple trace types at once.
test trace-6.1 {multiple ops traced at once} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x {read write unset} traceProc
catch {set x}
@@ -436,7 +434,7 @@ test trace-6.1 {multiple ops traced at once} {
set info
} {x {} read x {} write x {} read x {} write x {} unset}
test trace-6.2 {multiple ops traced on array element} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x(0) {read write unset} traceProc
catch {set x(0)}
@@ -448,7 +446,7 @@ test trace-6.2 {multiple ops traced on array element} {
set info
} {x 0 read x 0 write x 0 read x 0 write x 0 unset}
test trace-6.3 {multiple ops traced on whole array} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x {read write unset} traceProc
catch {set x(0)}
@@ -463,7 +461,7 @@ test trace-6.3 {multiple ops traced on whole array} {
# Check order of invocation of traces
test trace-7.1 {order of invocation of traces} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x read "traceTag 1"
trace add variable x read "traceTag 2"
@@ -474,7 +472,7 @@ test trace-7.1 {order of invocation of traces} {
set info
} {3 2 1 3 2 1}
test trace-7.2 {order of invocation of traces} {
- catch {unset x}
+ unset -nocomplain x
set x(0) 44
set info {}
trace add variable x(0) read "traceTag 1"
@@ -484,7 +482,7 @@ test trace-7.2 {order of invocation of traces} {
set info
} {3 2 1}
test trace-7.3 {order of invocation of traces} {
- catch {unset x}
+ unset -nocomplain x
set x(0) 44
set info {}
trace add variable x(0) read "traceTag 1"
@@ -500,7 +498,7 @@ test trace-7.3 {order of invocation of traces} {
# Check effects of errors in trace procedures
test trace-8.1 {error returns from traces} {
- catch {unset x}
+ unset -nocomplain x
set x 123
set info {}
trace add variable x read "traceTag 1"
@@ -508,7 +506,7 @@ test trace-8.1 {error returns from traces} {
list [catch {set x} msg] $msg $info
} {1 {can't read "x": trace returned error} {}}
test trace-8.2 {error returns from traces} {
- catch {unset x}
+ unset -nocomplain x
set x 123
set info {}
trace add variable x write "traceTag 1"
@@ -516,14 +514,14 @@ test trace-8.2 {error returns from traces} {
list [catch {set x 44} msg] $msg $info
} {1 {can't set "x": trace returned error} {}}
test trace-8.3 {error returns from traces} {
- catch {unset x}
+ unset -nocomplain x
set x 123
set info {}
trace add variable x write traceError
list [catch {append x 44} msg] $msg $info
} {1 {can't set "x": trace returned error} {}}
test trace-8.4 {error returns from traces} {
- catch {unset x}
+ unset -nocomplain x
set x 123
set info {}
trace add variable x unset "traceTag 1"
@@ -531,7 +529,7 @@ test trace-8.4 {error returns from traces} {
list [catch {unset x} msg] $msg $info
} {0 {} 1}
test trace-8.5 {error returns from traces} {
- catch {unset x}
+ unset -nocomplain x
set x(0) 123
set info {}
trace add variable x(0) read "traceTag 1"
@@ -541,7 +539,7 @@ test trace-8.5 {error returns from traces} {
list [catch {set x(0)} msg] $msg $info
} {1 {can't read "x(0)": trace returned error} 3}
test trace-8.6 {error returns from traces} {
- catch {unset x}
+ unset -nocomplain x
set x 123
trace add variable x unset traceError
list [catch {unset x} msg] $msg
@@ -550,7 +548,7 @@ test trace-8.7 {error returns from traces} {
# This test just makes sure that the memory for the error message
# gets deallocated correctly when the trace is invoked again or
# when the trace is deleted.
- catch {unset x}
+ unset -nocomplain x
set x 123
trace add variable x read traceError
catch {set x}
@@ -571,7 +569,7 @@ test trace-8.8 {error returns from traces} {
trace add variable ::x write [list foo $::x]
error "foo"
}
- catch {unset ::x ::y}
+ unset -nocomplain ::x ::y
set x junk
trace add variable ::x write [list foo $x]
for {set y 0} {$y<100} {incr y} {
@@ -585,31 +583,31 @@ test trace-8.8 {error returns from traces} {
# a new copy of the variables.
test trace-9.1 {be sure variable is unset before trace is called} {
- catch {unset x}
+ unset -nocomplain x
set x 33
set info {}
- trace add variable x unset {traceCheck {uplevel set x}}
+ trace add variable x unset {traceCheck {uplevel 1 set x}}
unset x
set info
} {1 {can't read "x": no such variable}}
test trace-9.2 {be sure variable is unset before trace is called} {
- catch {unset x}
+ unset -nocomplain x
set x 33
set info {}
- trace add variable x unset {traceCheck {uplevel set x 22}}
+ trace add variable x unset {traceCheck {uplevel 1 set x 22}}
unset x
concat $info [list [catch {set x} msg] $msg]
} {0 22 0 22}
test trace-9.3 {be sure traces are cleared before unset trace called} {
- catch {unset x}
+ unset -nocomplain x
set x 33
set info {}
- trace add variable x unset {traceCheck {uplevel trace info variable x}}
+ trace add variable x unset {traceCheck {uplevel 1 trace info variable x}}
unset x
set info
} {0 {}}
test trace-9.4 {set new trace during unset trace} {
- catch {unset x}
+ unset -nocomplain x
set x 33
set info {}
trace add variable x unset {traceCheck {global x; trace add variable x unset traceProc}}
@@ -618,23 +616,23 @@ test trace-9.4 {set new trace during unset trace} {
} {0 {} {unset traceProc}}
test trace-10.1 {make sure array elements are unset before traces are called} {
- catch {unset x}
+ unset -nocomplain x
set x(0) 33
set info {}
- trace add variable x(0) unset {traceCheck {uplevel set x(0)}}
+ trace add variable x(0) unset {traceCheck {uplevel 1 set x(0)}}
unset x(0)
set info
} {1 {can't read "x(0)": no such element in array}}
test trace-10.2 {make sure array elements are unset before traces are called} {
- catch {unset x}
+ unset -nocomplain x
set x(0) 33
set info {}
- trace add variable x(0) unset {traceCheck {uplevel set x(0) zzz}}
+ trace add variable x(0) unset {traceCheck {uplevel 1 set x(0) zzz}}
unset x(0)
concat $info [list [catch {set x(0)} msg] $msg]
} {0 zzz 0 zzz}
test trace-10.3 {array elements are unset before traces are called} {
- catch {unset x}
+ unset -nocomplain x
set x(0) 33
set info {}
trace add variable x(0) unset {traceCheck {global x; trace info variable x(0)}}
@@ -642,49 +640,49 @@ test trace-10.3 {array elements are unset before traces are called} {
set info
} {0 {}}
test trace-10.4 {set new array element trace during unset trace} {
- catch {unset x}
+ unset -nocomplain x
set x(0) 33
set info {}
- trace add variable x(0) unset {traceCheck {uplevel {trace add variable x(0) read {}}}}
- catch {unset x(0)}
+ trace add variable x(0) unset {traceCheck {uplevel 1 {trace add variable x(0) read {}}}}
+ unset -nocomplain x(0)
concat $info [trace info variable x(0)]
} {0 {} {read {}}}
test trace-11.1 {make sure arrays are unset before traces are called} {
- catch {unset x}
+ unset -nocomplain x
set x(0) 33
set info {}
- trace add variable x unset {traceCheck {uplevel set x(0)}}
+ trace add variable x unset {traceCheck {uplevel 1 set x(0)}}
unset x
set info
} {1 {can't read "x(0)": no such variable}}
test trace-11.2 {make sure arrays are unset before traces are called} {
- catch {unset x}
+ unset -nocomplain x
set x(y) 33
set info {}
- trace add variable x unset {traceCheck {uplevel set x(y) 22}}
+ trace add variable x unset {traceCheck {uplevel 1 set x(y) 22}}
unset x
concat $info [list [catch {set x(y)} msg] $msg]
} {0 22 0 22}
test trace-11.3 {make sure arrays are unset before traces are called} {
- catch {unset x}
+ unset -nocomplain x
set x(y) 33
set info {}
- trace add variable x unset {traceCheck {uplevel array exists x}}
+ trace add variable x unset {traceCheck {uplevel 1 array exists x}}
unset x
set info
} {0 0}
test trace-11.4 {make sure arrays are unset before traces are called} {
- catch {unset x}
+ unset -nocomplain x
set x(y) 33
set info {}
- set cmd {traceCheck {uplevel {trace info variable x}}}
+ set cmd {traceCheck {uplevel 1 {trace info variable x}}}
trace add variable x unset $cmd
unset x
set info
} {0 {}}
test trace-11.5 {set new array trace during unset trace} {
- catch {unset x}
+ unset -nocomplain x
set x(y) 33
set info {}
trace add variable x unset {traceCheck {global x; trace add variable x read {}}}
@@ -692,7 +690,7 @@ test trace-11.5 {set new array trace during unset trace} {
concat $info [trace info variable x]
} {0 {} {read {}}}
test trace-11.6 {create scalar during array unset trace} {
- catch {unset x}
+ unset -nocomplain x
set x(y) 33
set info {}
trace add variable x unset {traceCheck {global x; set x 44}}
@@ -703,52 +701,52 @@ test trace-11.6 {create scalar during array unset trace} {
# Check special conditions (e.g. errors) in Tcl_TraceVar2.
test trace-12.1 {creating array when setting variable traces} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x(0) write traceProc
list [catch {set x 22} msg] $msg
} {1 {can't set "x": variable is array}}
test trace-12.2 {creating array when setting variable traces} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x(0) write traceProc
list [catch {set x(0)} msg] $msg
} {1 {can't read "x(0)": no such element in array}}
test trace-12.3 {creating array when setting variable traces} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x(0) write traceProc
set x(0) 22
set info
} {x 0 write}
test trace-12.4 {creating variable when setting variable traces} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x write traceProc
list [catch {set x} msg] $msg
} {1 {can't read "x": no such variable}}
test trace-12.5 {creating variable when setting variable traces} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x write traceProc
set x 22
set info
} {x {} write}
test trace-12.6 {creating variable when setting variable traces} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x write traceProc
set x(0) 22
set info
} {x 0 write}
test trace-12.7 {create array element during read trace} {
- catch {unset x}
+ unset -nocomplain x
set x(2) zzz
trace add variable x read {traceCrtElement xyzzy}
list [catch {set x(3)} msg] $msg
} {0 xyzzy}
test trace-12.8 {errors when setting variable traces} {
- catch {unset x}
+ unset -nocomplain x
set x 44
list [catch {trace add variable x(0) write traceProc} msg] $msg
} {1 {can't trace "x(0)": variable isn't array}}
@@ -762,7 +760,7 @@ test trace-13.1 {delete one trace from another} {
trace remove variable x read {traceTag 3}
trace remove variable x read {traceTag 4}
}
- catch {unset x}
+ unset -nocomplain x
set x 44
set info {}
trace add variable x read {traceTag 1}
@@ -916,13 +914,13 @@ test trace-14.11 {trace command, "trace variable" errors} {
test trace-14.12 {trace command ("remove variable" option)} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x write traceProc
trace remove variable x write traceProc
} {}
test trace-14.13 {trace command ("remove variable" option)} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x write traceProc
trace remove variable x write traceProc
@@ -930,7 +928,7 @@ test trace-14.13 {trace command ("remove variable" option)} {
set info
} {}
test trace-14.14 {trace command ("remove variable" option)} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x write {traceTag 1}
trace add variable x write traceProc
@@ -945,7 +943,7 @@ test trace-14.14 {trace command ("remove variable" option)} {
set info
} {2 x {} write 1 2 1 2}
test trace-14.15 {trace command ("remove variable" option)} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x write {traceTag 1}
trace remove variable x write non_existent
@@ -953,27 +951,27 @@ test trace-14.15 {trace command ("remove variable" option)} {
set info
} {1}
test trace-14.16 {trace command ("info variable" option)} {
- catch {unset x}
+ unset -nocomplain x
trace add variable x write {traceTag 1}
trace add variable x write traceProc
trace add variable x write {traceTag 2}
trace info variable x
} {{write {traceTag 2}} {write traceProc} {write {traceTag 1}}}
test trace-14.17 {trace command ("info variable" option)} {
- catch {unset x}
+ unset -nocomplain x
trace info variable x
} {}
test trace-14.18 {trace command ("info variable" option)} {
- catch {unset x}
+ unset -nocomplain x
trace info variable x(0)
} {}
test trace-14.19 {trace command ("info variable" option)} {
- catch {unset x}
+ unset -nocomplain x
set x 44
trace info variable x(0)
} {}
test trace-14.20 {trace command ("info variable" option)} {
- catch {unset x}
+ unset -nocomplain x
set x 44
trace add variable x write {traceTag 1}
proc check {} {global x; trace info variable x}
@@ -983,7 +981,7 @@ test trace-14.20 {trace command ("info variable" option)} {
# Check fancy trace commands (long ones, weird arguments, etc.)
test trace-15.1 {long trace command} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x write {traceTag {This is a very very long argument. It's \
designed to test out the facilities of TraceVarProc for dealing \
@@ -1001,14 +999,14 @@ test trace-15.2 {long trace command result to ignore} {
proc longResult {args} {return "quite a bit of text, designed to
generate a core leak if this command file is invoked over and over again
and memory isn't being recycled correctly"}
- catch {unset x}
+ unset -nocomplain x
trace add variable x write longResult
set x 44
set x 5
set x abcde
} abcde
test trace-15.3 {special list-handling in trace commands} {
- catch {unset "x y z"}
+ unset -nocomplain "x y z"
set "x y z(a\n\{)" 44
set info {}
trace add variable "x y z(a\n\{)" write traceProc
@@ -1020,18 +1018,18 @@ test trace-15.3 {special list-handling in trace commands} {
proc traceUnset {unsetName args} {
global info
- upvar $unsetName x
+ upvar 1 $unsetName x
lappend info [catch {unset x} msg] $msg [catch {set x} msg] $msg
}
proc traceReset {unsetName resetName args} {
global info
- upvar $unsetName x $resetName y
+ upvar 1 $unsetName x $resetName y
lappend info [catch {unset x} msg] $msg [catch {set y xyzzy} msg] $msg
}
proc traceReset2 {unsetName resetName args} {
global info
- lappend info [catch {uplevel unset $unsetName} msg] $msg \
- [catch {uplevel set $resetName xyzzy} msg] $msg
+ lappend info [catch {uplevel 1 unset $unsetName} msg] $msg \
+ [catch {uplevel 1 set $resetName xyzzy} msg] $msg
}
proc traceAppend {string name1 name2 op} {
global info
@@ -1039,7 +1037,7 @@ proc traceAppend {string name1 name2 op} {
}
test trace-16.1 {unsets during read traces} {
- catch {unset y}
+ unset -nocomplain y
set y 1234
set info {}
trace add variable y read {traceUnset y}
@@ -1047,49 +1045,49 @@ test trace-16.1 {unsets during read traces} {
lappend info [catch {set y} msg] $msg
} {unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y": no such variable}}
test trace-16.2 {unsets during read traces} {
- catch {unset y}
+ unset -nocomplain y
set y(0) 1234
set info {}
trace add variable y(0) read {traceUnset y(0)}
lappend info [catch {set y(0)} msg] $msg
} {0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such element in array}}
test trace-16.3 {unsets during read traces} {
- catch {unset y}
+ unset -nocomplain y
set y(0) 1234
set info {}
trace add variable y(0) read {traceUnset y}
lappend info [catch {set y(0)} msg] $msg
} {0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such variable}}
test trace-16.4 {unsets during read traces} {
- catch {unset y}
+ unset -nocomplain y
set y 1234
set info {}
trace add variable y read {traceReset y y}
lappend info [catch {set y} msg] $msg
} {0 {} 0 xyzzy 0 xyzzy}
test trace-16.5 {unsets during read traces} {
- catch {unset y}
+ unset -nocomplain y
set y(0) 1234
set info {}
trace add variable y(0) read {traceReset y(0) y(0)}
lappend info [catch {set y(0)} msg] $msg
} {0 {} 0 xyzzy 0 xyzzy}
test trace-16.6 {unsets during read traces} {
- catch {unset y}
+ unset -nocomplain y
set y(0) 1234
set info {}
trace add variable y(0) read {traceReset y y(0)}
lappend info [catch {set y(0)} msg] $msg [catch {set y(0)} msg] $msg
} {0 {} 1 {can't set "y": upvar refers to element in deleted array} 1 {can't read "y(0)": no such variable} 1 {can't read "y(0)": no such variable}}
test trace-16.7 {unsets during read traces} {
- catch {unset y}
+ unset -nocomplain y
set y(0) 1234
set info {}
trace add variable y(0) read {traceReset2 y y(0)}
lappend info [catch {set y(0)} msg] $msg [catch {set y(0)} msg] $msg
} {0 {} 0 xyzzy 1 {can't read "y(0)": no such element in array} 0 xyzzy}
test trace-16.8 {unsets during write traces} {
- catch {unset y}
+ unset -nocomplain y
set y 1234
set info {}
trace add variable y write {traceUnset y}
@@ -1097,91 +1095,91 @@ test trace-16.8 {unsets during write traces} {
lappend info [catch {set y xxx} msg] $msg
} {unset 0 {} 1 {can't read "x": no such variable} 0 {}}
test trace-16.9 {unsets during write traces} {
- catch {unset y}
+ unset -nocomplain y
set y(0) 1234
set info {}
trace add variable y(0) write {traceUnset y(0)}
lappend info [catch {set y(0) xxx} msg] $msg
} {0 {} 1 {can't read "x": no such variable} 0 {}}
test trace-16.10 {unsets during write traces} {
- catch {unset y}
+ unset -nocomplain y
set y(0) 1234
set info {}
trace add variable y(0) write {traceUnset y}
lappend info [catch {set y(0) xxx} msg] $msg
} {0 {} 1 {can't read "x": no such variable} 0 {}}
test trace-16.11 {unsets during write traces} {
- catch {unset y}
+ unset -nocomplain y
set y 1234
set info {}
trace add variable y write {traceReset y y}
lappend info [catch {set y xxx} msg] $msg
} {0 {} 0 xyzzy 0 xyzzy}
test trace-16.12 {unsets during write traces} {
- catch {unset y}
+ unset -nocomplain y
set y(0) 1234
set info {}
trace add variable y(0) write {traceReset y(0) y(0)}
lappend info [catch {set y(0) xxx} msg] $msg
} {0 {} 0 xyzzy 0 xyzzy}
test trace-16.13 {unsets during write traces} {
- catch {unset y}
+ unset -nocomplain y
set y(0) 1234
set info {}
trace add variable y(0) write {traceReset y y(0)}
lappend info [catch {set y(0) xxx} msg] $msg [catch {set y(0)} msg] $msg
} {0 {} 1 {can't set "y": upvar refers to element in deleted array} 0 {} 1 {can't read "y(0)": no such variable}}
test trace-16.14 {unsets during write traces} {
- catch {unset y}
+ unset -nocomplain y
set y(0) 1234
set info {}
trace add variable y(0) write {traceReset2 y y(0)}
lappend info [catch {set y(0) xxx} msg] $msg [catch {set y(0)} msg] $msg
} {0 {} 0 xyzzy 0 {} 0 xyzzy}
test trace-16.15 {unsets during unset traces} {
- catch {unset y}
+ unset -nocomplain y
set y 1234
set info {}
trace add variable y unset {traceUnset y}
lappend info [catch {unset y} msg] $msg [catch {set y} msg] $msg
} {1 {can't unset "x": no such variable} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y": no such variable}}
test trace-16.16 {unsets during unset traces} {
- catch {unset y}
+ unset -nocomplain y
set y(0) 1234
set info {}
trace add variable y(0) unset {traceUnset y(0)}
lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg
} {1 {can't unset "x": no such variable} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y(0)": no such element in array}}
test trace-16.17 {unsets during unset traces} {
- catch {unset y}
+ unset -nocomplain y
set y(0) 1234
set info {}
trace add variable y(0) unset {traceUnset y}
lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg
} {0 {} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y(0)": no such variable}}
test trace-16.18 {unsets during unset traces} {
- catch {unset y}
+ unset -nocomplain y
set y 1234
set info {}
trace add variable y unset {traceReset2 y y}
lappend info [catch {unset y} msg] $msg [catch {set y} msg] $msg
} {1 {can't unset "y": no such variable} 0 xyzzy 0 {} 0 xyzzy}
test trace-16.19 {unsets during unset traces} {
- catch {unset y}
+ unset -nocomplain y
set y(0) 1234
set info {}
trace add variable y(0) unset {traceReset2 y(0) y(0)}
lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg
} {1 {can't unset "y(0)": no such element in array} 0 xyzzy 0 {} 0 xyzzy}
test trace-16.20 {unsets during unset traces} {
- catch {unset y}
+ unset -nocomplain y
set y(0) 1234
set info {}
trace add variable y(0) unset {traceReset2 y y(0)}
lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg
} {0 {} 0 xyzzy 0 {} 0 xyzzy}
test trace-16.21 {unsets cancelling traces} {
- catch {unset y}
+ unset -nocomplain y
set y 1234
set info {}
trace add variable y read {traceAppend first}
@@ -1191,7 +1189,7 @@ test trace-16.21 {unsets cancelling traces} {
lappend info [catch {set y} msg] $msg
} {third unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y": no such variable}}
test trace-16.22 {unsets cancelling traces} {
- catch {unset y}
+ unset -nocomplain y
set y(0) 1234
set info {}
trace add variable y(0) read {traceAppend first}
@@ -1204,19 +1202,19 @@ test trace-16.22 {unsets cancelling traces} {
# Check various non-interference between traces and other things.
test trace-17.1 {trace doesn't prevent unset errors} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x unset {traceProc}
list [catch {unset x} msg] $msg $info
} {1 {can't unset "x": no such variable} {x {} unset}}
test trace-17.2 {traced variables must survive procedure exits} {
- catch {unset x}
+ unset -nocomplain x
proc p1 {} {global x; trace add variable x write traceProc}
p1
trace info variable x
} {{write traceProc}}
test trace-17.3 {traced variables must survive procedure exits} {
- catch {unset x}
+ unset -nocomplain x
set info {}
proc p1 {} {global x; trace add variable x write traceProc}
p1
@@ -1229,7 +1227,7 @@ test trace-17.3 {traced variables must survive procedure exits} {
test trace-18.1 {unset traces on procedure returns} {
proc p1 {x y} {set a 44; p2 14}
- proc p2 {z} {trace add variable z unset {traceCheck {lsort [uplevel {info vars}]}}}
+ proc p2 {z} {trace add variable z unset {traceCheck {lsort [uplevel 1 {info vars}]}}}
set info {}
p1 foo bar
set info
@@ -1269,8 +1267,7 @@ test trace-18.4 {namespace delete / trace vdelete combo, Bug \#1338280} {
# Delete arrays when done, so they can be re-used as scalars
# elsewhere.
-catch {unset x}
-catch {unset y}
+unset -nocomplain x y
test trace-19.0.1 {trace add command (command existence)} {
# Just in case!
@@ -1542,8 +1539,7 @@ proc foo {b} { set a $b }
# Delete arrays when done, so they can be re-used as scalars
# elsewhere.
-catch {unset x}
-catch {unset y}
+unset -nocomplain x y
# Delete procedures when done, so we don't clash with other tests
# (e.g. foobar will clash with 'unknown' tests).
@@ -2050,7 +2046,7 @@ test trace-28.1 {enterstep and leavestep traces with update idletasks (615043)}
trace remove execution foo {enter enterstep leavestep leave} \
[list traceExecute foo]
rename foo {}
- catch {unset a}
+ unset -nocomplain a
join $info "\n"
} {foo foo enter
foo {set a 1} enterstep
@@ -2634,9 +2630,8 @@ catch {rename traceproc {}}
catch {rename runbase {}}
# Unset the variable when done
-catch {unset info}
-catch {unset base}
+unset -nocomplain info base
# cleanup
-::tcltest::cleanupTests
+cleanupTests
return
diff --git a/tests/unixInit.test b/tests/unixInit.test
index 9ba9c11..05338ed 100644
--- a/tests/unixInit.test
+++ b/tests/unixInit.test
@@ -11,7 +11,7 @@
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require tcltest 2.2
-namespace import -force ::tcltest::*
+namespace import ::tcltest::*
unset -nocomplain path
catch {set oldlang $env(LANG)}
set env(LANG) C
@@ -44,11 +44,11 @@ test unixInit-1.2 {initialisation: standard channel type deduction} {unix stdio}
set pipe1 [open "|[list [interpreter]]" r+]
puts $pipe1 {
proc accept {channel host port} {
- puts $channel {puts [fconfigure stdin -peername]; exit}
+ puts $channel {puts [chan configure stdin -peername]; exit}
close $channel
exit
}
- puts [fconfigure [socket -server accept -myaddr 127.0.0.1 0] -sockname]
+ puts [chan configure [socket -server accept -myaddr 127.0.0.1 0] -sockname]
vwait forever \
}
# Note the backslash above; this is important to make sure that the whole
@@ -64,8 +64,8 @@ test unixInit-1.2 {initialisation: standard channel type deduction} {unix stdio}
set pipe2 [open "|[list [interpreter] <@$sock]" r]
set result [gets $pipe2]
# Clear any pending data; stops certain kinds of (non-important) errors
- fconfigure $pipe1 -blocking 0; gets $pipe1
- fconfigure $pipe2 -blocking 0; gets $pipe2
+ chan configure $pipe1 -blocking 0; gets $pipe1
+ chan configure $pipe2 -blocking 0; gets $pipe2
# Close the pipes and the socket.
close $pipe2
close $pipe1
@@ -329,7 +329,7 @@ test unixInit-3.1 {TclpSetInitialEncodings} -constraints {
} -body {
set env(LANG) C
set f [open "|[list [interpreter]]" w+]
- fconfigure $f -buffering none
+ chan configure $f -buffering none
puts $f {puts [encoding system]; exit}
set enc [gets $f]
close $f
@@ -344,7 +344,7 @@ test unixInit-3.2 {TclpSetInitialEncodings} -setup {
set env(LANG) japanese
set env(LC_ALL) japanese
set f [open "|[list [interpreter]]" w+]
- fconfigure $f -buffering none
+ chan configure $f -buffering none
puts $f {puts [encoding system]; exit}
set enc [gets $f]
close $f
@@ -390,7 +390,7 @@ test unixInit-7.1 {closed standard channel: Bug 772288} -constraints {
} -returnCodes 0
# cleanup
-catch {unset env(LANG)}
+unset -nocomplain env(LANG)
catch {set env(LANG) $oldlang}
unset -nocomplain path
::tcltest::cleanupTests
diff --git a/tests/unknown.test b/tests/unknown.test
index 40be6602..e80d3a6 100644
--- a/tests/unknown.test
+++ b/tests/unknown.test
@@ -11,12 +11,10 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
- namespace import -force ::tcltest::*
-}
+package require tcltest 2
+namespace import ::tcltest::*
-catch {unset x}
+unset -nocomplain x
catch {rename unknown unknown.old}
test unknown-1.1 {non-existent "unknown" command} {
@@ -59,7 +57,7 @@ test unknown-4.1 {errors in "unknown" procedure} {
# cleanup
catch {rename unknown {}}
catch {rename unknown.old unknown}
-::tcltest::cleanupTests
+cleanupTests
return
# Local Variables:
diff --git a/unix/Makefile.in b/unix/Makefile.in
index f8dd67c..fe95797 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -851,8 +851,8 @@ install-libraries: libraries
@echo "Installing package tcltest 2.3.5 as a Tcl Module";
@$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.5.tm;
- @echo "Installing package platform 1.0.10 as a Tcl Module";
- @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.10.tm;
+ @echo "Installing package platform 1.0.11 as a Tcl Module";
+ @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.11.tm;
@echo "Installing package platform::shell 1.1.4 as a Tcl Module";
@$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform/shell-1.1.4.tm;
@@ -866,10 +866,39 @@ install-libraries: libraries
"$(SCRIPT_INSTALL_DIR)"/tm.tcl; \
fi
-install-tzdata: ${NATIVE_TCLSH}
+install-tzdata:
+ @for i in tzdata; \
+ do \
+ if [ ! -d "$(SCRIPT_INSTALL_DIR)"/$$i ] ; then \
+ echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \
+ $(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)"/$$i; \
+ else true; \
+ fi; \
+ done;
@echo "Installing time zone files to $(SCRIPT_INSTALL_DIR)/tzdata/"
- @${NATIVE_TCLSH} $(TOOL_DIR)/installData.tcl \
- $(TOP_DIR)/library/tzdata "$(SCRIPT_INSTALL_DIR)"/tzdata
+ @for i in $(TOP_DIR)/library/tzdata/* ; do \
+ if [ -d $$i ] ; then \
+ ii=`basename $$i`; \
+ if [ ! -d "$(SCRIPT_INSTALL_DIR)"/tzdata/$$ii ] ; then \
+ $(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)"/tzdata/$$ii; \
+ fi; \
+ for j in $$i/* ; do \
+ if [ -d $$j ] ; then \
+ jj=`basename $$j`; \
+ if [ ! -d "$(SCRIPT_INSTALL_DIR)"/tzdata/$$ii/$$jj ] ; then \
+ $(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)"/tzdata/$$ii/$$jj; \
+ fi; \
+ for k in $$j/* ; do \
+ $(INSTALL_DATA) $$k "$(SCRIPT_INSTALL_DIR)"/tzdata/$$ii/$$jj; \
+ done; \
+ else \
+ $(INSTALL_DATA) $$j "$(SCRIPT_INSTALL_DIR)"/tzdata/$$ii; \
+ fi; \
+ done; \
+ else \
+ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/tzdata; \
+ fi; \
+ done;
install-msgs:
@for i in msgs; \
diff --git a/win/Makefile.in b/win/Makefile.in
index 8582600..2764813 100644
--- a/win/Makefile.in
+++ b/win/Makefile.in
@@ -650,8 +650,8 @@ install-libraries: libraries install-tzdata install-msgs
@$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.5.0.tm;
@echo "Installing package tcltest 2.3.5 as a Tcl Module";
@$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.5.tm;
- @echo "Installing package platform 1.0.10 as a Tcl Module";
- @$(COPY) $(ROOT_DIR)/library/platform/platform.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform-1.0.10.tm;
+ @echo "Installing package platform 1.0.11 as a Tcl Module";
+ @$(COPY) $(ROOT_DIR)/library/platform/platform.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform-1.0.11.tm;
@echo "Installing package platform::shell 1.1.4 as a Tcl Module";
@$(COPY) $(ROOT_DIR)/library/platform/shell.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform/shell-1.1.4.tm;
@echo "Installing encodings";