summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorjan.nijtmans <nijtmans@users.sourceforge.net>2013-01-31 07:56:54 (GMT)
committerjan.nijtmans <nijtmans@users.sourceforge.net>2013-01-31 07:56:54 (GMT)
commit0287c4445a7538f25ec9186890ef648f5241bc8e (patch)
treef54839188b379d2b91c599c2375a3c8d3c991b09
parente54a19b3bf910e66e23bb7583a5a2c3043361f94 (diff)
parentf385174158496b543825ede31d40b25de7196e51 (diff)
downloadtcl-0287c4445a7538f25ec9186890ef648f5241bc8e.zip
tcl-0287c4445a7538f25ec9186890ef648f5241bc8e.tar.gz
tcl-0287c4445a7538f25ec9186890ef648f5241bc8e.tar.bz2
Merge trunk
Handle caching of string intRep in more internal objTypes
-rw-r--r--ChangeLog9
-rw-r--r--generic/tclBinary.c9
-rw-r--r--generic/tclCompile.c20
-rw-r--r--generic/tclDictObj.c14
-rw-r--r--generic/tclEncoding.c17
-rw-r--r--generic/tclExecute.c13
-rw-r--r--generic/tclIndexObj.c27
-rw-r--r--generic/tclInt.h7
-rw-r--r--generic/tclNamesp.c26
-rw-r--r--generic/tclPathObj.c5
-rw-r--r--generic/tclStringObj.c10
-rw-r--r--library/auto.tcl23
-rw-r--r--library/init.tcl50
-rw-r--r--library/package.tcl22
-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.test13
-rw-r--r--tests/parse.test22
-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
-rw-r--r--tests/tcltest.test17
-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.in4
-rw-r--r--win/Makefile.in4
40 files changed, 523 insertions, 493 deletions
diff --git a/ChangeLog b/ChangeLog
index 270ca22..fac0bd3 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,12 @@
+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-26 Jan Nijtmans <nijtmans@users.sf.net>
* unix/tclUnixCompat.c: [Bug 3601804]: platformCPUID segmentation
diff --git a/generic/tclBinary.c b/generic/tclBinary.c
index 6b25dc1..328faaf 100644
--- a/generic/tclBinary.c
+++ b/generic/tclBinary.c
@@ -402,6 +402,8 @@ SetByteArrayFromAny(
Tcl_UniChar ch;
if (objPtr->typePtr != &tclByteArrayType) {
+ void *stringIntRep = NULL;
+
src = TclGetStringFromObj(objPtr, &length);
srcEnd = src + length;
@@ -414,9 +416,15 @@ SetByteArrayFromAny(
byteArrayPtr->used = dst - byteArrayPtr->bytes;
byteArrayPtr->allocated = length;
+ /* If previous objType was string, keep the internal representation */
+ if(objPtr->typePtr == &tclStringType) {
+ stringIntRep = objPtr->internalRep.twoPtrValue.ptr2;
+ objPtr->internalRep.twoPtrValue.ptr2 = NULL;
+ }
TclFreeIntRep(objPtr);
objPtr->typePtr = &tclByteArrayType;
SET_BYTEARRAY(objPtr, byteArrayPtr);
+ objPtr->internalRep.twoPtrValue.ptr2 = stringIntRep;
}
return TCL_OK;
}
@@ -444,7 +452,6 @@ FreeByteArrayInternalRep(
{
if (objPtr->internalRep.twoPtrValue.ptr2) {
ckfree(objPtr->internalRep.twoPtrValue.ptr2);
- objPtr->internalRep.twoPtrValue.ptr2 = NULL;
}
ckfree((char *) GET_BYTEARRAY(objPtr));
objPtr->typePtr = NULL;
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index cd3dfcd..32dfe8c 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -488,6 +488,7 @@ TclSetByteCodeFromAny(
int length, result = TCL_OK;
const char *stringPtr;
ContLineLoc* clLocPtr;
+ void *stringIntRep = NULL;
#ifdef TCL_COMPILE_DEBUG
if (!traceInitialized) {
@@ -553,7 +554,13 @@ TclSetByteCodeFromAny(
TclVerifyLocalLiteralTable(&compEnv);
#endif /*TCL_COMPILE_DEBUG*/
+ /* If previous objType was string, keep the internal representation */
+ if(objPtr->typePtr == &tclStringType) {
+ stringIntRep = objPtr->internalRep.twoPtrValue.ptr2;
+ objPtr->internalRep.twoPtrValue.ptr2 = NULL;
+ }
TclInitByteCodeObj(objPtr, &compEnv);
+ objPtr->internalRep.twoPtrValue.ptr2 = stringIntRep;
#ifdef TCL_COMPILE_DEBUG
if (tclTraceCompile >= 2) {
TclPrintByteCodeObj(interp, objPtr);
@@ -682,9 +689,10 @@ FreeByteCodeInternalRep(
if (codePtr->refCount <= 0) {
TclCleanupByteCode(codePtr);
}
+ if (objPtr->internalRep.twoPtrValue.ptr2) {
+ ckfree(objPtr->internalRep.twoPtrValue.ptr2);
+ }
objPtr->typePtr = NULL;
- objPtr->internalRep.twoPtrValue.ptr1 = NULL;
- objPtr->internalRep.twoPtrValue.ptr2 = NULL;
}
/*
@@ -2111,6 +2119,7 @@ TclInitByteCodeObj(
size_t codeBytes, objArrayBytes, exceptArrayBytes, cmdLocBytes;
size_t auxDataArrayBytes, structureSize;
register unsigned char *p;
+ void *stringIntRep = NULL;
#ifdef TCL_COMPILE_DEBUG
unsigned char *nextPtr;
#endif
@@ -2218,6 +2227,11 @@ TclInitByteCodeObj(
RecordByteCodeStats(codePtr);
#endif /* TCL_COMPILE_STATS */
+ /* If previous objType was string, keep the internal representation */
+ if (objPtr->typePtr == &tclStringType) {
+ stringIntRep = objPtr->internalRep.twoPtrValue.ptr2;
+ objPtr->internalRep.twoPtrValue.ptr2 = NULL;
+ }
/*
* Free the old internal rep then convert the object to a bytecode object
* by making its internal rep point to the just compiled ByteCode.
@@ -2225,7 +2239,7 @@ TclInitByteCodeObj(
TclFreeIntRep(objPtr);
objPtr->internalRep.twoPtrValue.ptr1 = (void *) codePtr;
- objPtr->internalRep.twoPtrValue.ptr2 = NULL;
+ objPtr->internalRep.twoPtrValue.ptr2 = stringIntRep;
objPtr->typePtr = &tclByteCodeType;
/*
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index 4aa16cf..5886484 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -403,10 +403,7 @@ FreeDictInternalRep(
}
if (dictPtr->internalRep.twoPtrValue.ptr2) {
ckfree(dictPtr->internalRep.twoPtrValue.ptr2);
- dictPtr->internalRep.twoPtrValue.ptr2 = NULL;
}
-
- dictPtr->internalRep.twoPtrValue.ptr1 = NULL; /* Belt and braces! */
dictPtr->typePtr = NULL;
}
@@ -580,6 +577,7 @@ SetDictFromAny(
Tcl_HashEntry *hPtr;
int isNew, result;
Dict *dict = (Dict *) ckalloc(sizeof(Dict));
+ void *stringIntRep = NULL;
InitChainTable(dict);
@@ -681,7 +679,13 @@ SetDictFromAny(
}
}
- /*
+ /* If previous objType was string, keep the internal representation */
+ if (objPtr->typePtr == &tclStringType) {
+ stringIntRep = objPtr->internalRep.twoPtrValue.ptr2;
+ objPtr->internalRep.twoPtrValue.ptr2 = NULL;
+ }
+
+ /*
* Free the old internalRep before setting the new one. We do this as late
* as possible to allow the conversion code, in particular
* Tcl_GetStringFromObj, to use that old internalRep.
@@ -692,7 +696,7 @@ SetDictFromAny(
dict->chain = NULL;
dict->refcount = 1;
objPtr->internalRep.twoPtrValue.ptr1 = dict;
- objPtr->internalRep.twoPtrValue.ptr2 = NULL;
+ objPtr->internalRep.twoPtrValue.ptr2 = stringIntRep;
objPtr->typePtr = &tclDictType;
return TCL_OK;
diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c
index a27bb5f..137fe11 100644
--- a/generic/tclEncoding.c
+++ b/generic/tclEncoding.c
@@ -276,7 +276,7 @@ static int Iso88591ToUtfProc(ClientData clientData,
* See concerns raised in [Bug 1077262].
*/
-static Tcl_ObjType encodingType = {
+Tcl_ObjType tclEncodingType = {
"encoding", FreeEncodingIntRep, DupEncodingIntRep, NULL, NULL
};
@@ -306,16 +306,22 @@ Tcl_GetEncodingFromObj(
Tcl_Encoding *encodingPtr)
{
const char *name = Tcl_GetString(objPtr);
- if (objPtr->typePtr != &encodingType) {
+ if (objPtr->typePtr != &tclEncodingType) {
+ void *stringIntRep = NULL;
Tcl_Encoding encoding = Tcl_GetEncoding(interp, name);
if (encoding == NULL) {
return TCL_ERROR;
}
+ /* If previous objType was string, keep the internal representation */
+ if (objPtr->typePtr == &tclStringType) {
+ stringIntRep = objPtr->internalRep.twoPtrValue.ptr2;
+ objPtr->internalRep.twoPtrValue.ptr2 = NULL;
+ }
TclFreeIntRep(objPtr);
objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) encoding;
- objPtr->internalRep.twoPtrValue.ptr2 = NULL;
- objPtr->typePtr = &encodingType;
+ objPtr->internalRep.twoPtrValue.ptr2 = stringIntRep;
+ objPtr->typePtr = &tclEncodingType;
}
*encodingPtr = Tcl_GetEncoding(NULL, name);
return TCL_OK;
@@ -336,6 +342,9 @@ FreeEncodingIntRep(
Tcl_Obj *objPtr)
{
Tcl_FreeEncoding((Tcl_Encoding) objPtr->internalRep.twoPtrValue.ptr1);
+ if (objPtr->internalRep.twoPtrValue.ptr2) {
+ ckfree(objPtr->internalRep.twoPtrValue.ptr2);
+ }
objPtr->typePtr = NULL;
}
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index e110ced..20442da 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -635,7 +635,7 @@ static Tcl_Obj ** StackReallocWords(Tcl_Interp *interp, int numWords);
* compiled bytecode for Tcl expressions.
*/
-static Tcl_ObjType exprCodeType = {
+Tcl_ObjType tclExprCodeType = {
"exprcode",
FreeExprCodeInternalRep, /* freeIntRepProc */
DupExprCodeInternalRep, /* dupIntRepProc */
@@ -1197,7 +1197,7 @@ Tcl_ExprObj(
* Get the expression ByteCode from the object. If it exists, make sure it
* is valid in the current context.
*/
- if (objPtr->typePtr == &exprCodeType) {
+ if (objPtr->typePtr == &tclExprCodeType) {
Namespace *namespacePtr = iPtr->varFramePtr->nsPtr;
codePtr = (ByteCode *) objPtr->internalRep.twoPtrValue.ptr1;
@@ -1209,7 +1209,7 @@ Tcl_ExprObj(
objPtr->typePtr = (Tcl_ObjType *) NULL;
}
}
- if (objPtr->typePtr != &exprCodeType) {
+ if (objPtr->typePtr != &tclExprCodeType) {
/*
* TIP #280: No invoker (yet) - Expression compilation.
*/
@@ -1238,7 +1238,7 @@ Tcl_ExprObj(
TclEmitOpcode(INST_DONE, &compEnv);
TclInitByteCodeObj(objPtr, &compEnv);
- objPtr->typePtr = &exprCodeType;
+ objPtr->typePtr = &tclExprCodeType;
TclFreeCompileEnv(&compEnv);
codePtr = (ByteCode *) objPtr->internalRep.twoPtrValue.ptr1;
#ifdef TCL_COMPILE_DEBUG
@@ -1344,9 +1344,10 @@ FreeExprCodeInternalRep(
if (codePtr->refCount <= 0) {
TclCleanupByteCode(codePtr);
}
+ if (objPtr->internalRep.twoPtrValue.ptr2) {
+ ckfree(objPtr->internalRep.twoPtrValue.ptr2);
+ }
objPtr->typePtr = NULL;
- objPtr->internalRep.twoPtrValue.ptr1 = NULL;
- objPtr->internalRep.twoPtrValue.ptr2 = NULL;
}
/*
diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c
index 8febcb6..310b31c 100644
--- a/generic/tclIndexObj.c
+++ b/generic/tclIndexObj.c
@@ -27,7 +27,7 @@ static void FreeIndex(Tcl_Obj *objPtr);
* that can be invoked by generic object code.
*/
-static Tcl_ObjType indexType = {
+Tcl_ObjType tclIndexType = {
"index", /* name */
FreeIndex, /* freeIntRepProc */
DupIndex, /* dupIntRepProc */
@@ -104,7 +104,7 @@ Tcl_GetIndexFromObj(
* the common case where the result is cached).
*/
- if (objPtr->typePtr == &indexType) {
+ if (objPtr->typePtr == &tclIndexType) {
IndexRep *indexRep = objPtr->internalRep.twoPtrValue.ptr1;
/*
@@ -178,7 +178,7 @@ Tcl_GetIndexFromObjStruct(
* See if there is a valid cached result from a previous lookup.
*/
- if (objPtr->typePtr == &indexType) {
+ if (objPtr->typePtr == &tclIndexType) {
indexRep = objPtr->internalRep.twoPtrValue.ptr1;
if (indexRep->tablePtr==tablePtr && indexRep->offset==offset) {
*indexPtr = indexRep->index;
@@ -239,14 +239,20 @@ Tcl_GetIndexFromObjStruct(
* operation.
*/
- if (objPtr->typePtr == &indexType) {
+ if (objPtr->typePtr == &tclIndexType) {
indexRep = objPtr->internalRep.twoPtrValue.ptr1;
} else {
+ void *stringIntRep = NULL;
+ /* If previous objType was string, keep the internal representation */
+ if (objPtr->typePtr == &tclStringType) {
+ stringIntRep = objPtr->internalRep.twoPtrValue.ptr2;
+ objPtr->internalRep.twoPtrValue.ptr2 = NULL;
+ }
TclFreeIntRep(objPtr);
indexRep = (IndexRep *) ckalloc(sizeof(IndexRep));
objPtr->internalRep.twoPtrValue.ptr1 = indexRep;
- objPtr->internalRep.twoPtrValue.ptr2 = NULL;
- objPtr->typePtr = &indexType;
+ objPtr->internalRep.twoPtrValue.ptr2 = stringIntRep;
+ objPtr->typePtr = &tclIndexType;
}
indexRep->tablePtr = (void *) tablePtr;
indexRep->offset = offset;
@@ -382,7 +388,7 @@ DupIndex(
memcpy(dupIndexRep, srcIndexRep, sizeof(IndexRep));
dupPtr->internalRep.twoPtrValue.ptr1 = dupIndexRep;
- dupPtr->typePtr = &indexType;
+ dupPtr->typePtr = &tclIndexType;
}
/*
@@ -407,6 +413,9 @@ FreeIndex(
Tcl_Obj *objPtr)
{
ckfree((char *) objPtr->internalRep.twoPtrValue.ptr1);
+ if (objPtr->internalRep.twoPtrValue.ptr2) {
+ ckfree(objPtr->internalRep.twoPtrValue.ptr2);
+ }
objPtr->typePtr = NULL;
}
@@ -532,7 +541,7 @@ Tcl_WrongNumArgs(
* Add the element, quoting it if necessary.
*/
- if (origObjv[i]->typePtr == &indexType) {
+ if (origObjv[i]->typePtr == &tclIndexType) {
register IndexRep *indexRep =
origObjv[i]->internalRep.twoPtrValue.ptr1;
@@ -588,7 +597,7 @@ Tcl_WrongNumArgs(
* Otherwise, just use the string rep.
*/
- if (objv[i]->typePtr == &indexType) {
+ if (objv[i]->typePtr == &tclIndexType) {
register IndexRep *indexRep = objv[i]->internalRep.twoPtrValue.ptr1;
Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), NULL);
diff --git a/generic/tclInt.h b/generic/tclInt.h
index d5a479b..2e533c9 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2463,11 +2463,16 @@ MODULE_SCOPE Tcl_ObjType tclBignumType;
MODULE_SCOPE Tcl_ObjType tclBooleanType;
MODULE_SCOPE Tcl_ObjType tclByteArrayType;
MODULE_SCOPE Tcl_ObjType tclByteCodeType;
+MODULE_SCOPE Tcl_ObjType tclDictType;
MODULE_SCOPE Tcl_ObjType tclDoubleType;
MODULE_SCOPE Tcl_ObjType tclEndOffsetType;
+MODULE_SCOPE Tcl_ObjType tclEncodingType;
+MODULE_SCOPE Tcl_ObjType tclExprCodeType;
+MODULE_SCOPE Tcl_ObjType tclFsPathType;
+MODULE_SCOPE Tcl_ObjType tclIndexType;
MODULE_SCOPE Tcl_ObjType tclIntType;
MODULE_SCOPE Tcl_ObjType tclListType;
-MODULE_SCOPE Tcl_ObjType tclDictType;
+MODULE_SCOPE Tcl_ObjType tclNsNameType;
MODULE_SCOPE Tcl_ObjType tclProcBodyType;
MODULE_SCOPE Tcl_ObjType tclStringType;
MODULE_SCOPE Tcl_ObjType tclArraySearchType;
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 3824707..5d14433 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -229,7 +229,7 @@ static void UnlinkNsPath(Namespace *nsPtr);
* the object.
*/
-static Tcl_ObjType nsNameType = {
+Tcl_ObjType tclNsNameType = {
"nsName", /* the type's name */
FreeNsNameInternalRep, /* freeIntRepProc */
DupNsNameInternalRep, /* dupIntRepProc */
@@ -2700,7 +2700,7 @@ GetNamespaceFromObj(
ResolvedNsName *resNamePtr;
Namespace *nsPtr, *refNsPtr;
- if (objPtr->typePtr == &nsNameType) {
+ if (objPtr->typePtr == &tclNsNameType) {
/*
* Check that the ResolvedNsName is still valid; avoid letting the ref
* cross interps.
@@ -4615,6 +4615,9 @@ FreeNsNameInternalRep(
}
ckfree((char *) resNamePtr);
}
+ if (objPtr->internalRep.twoPtrValue.ptr2) {
+ ckfree(objPtr->internalRep.twoPtrValue.ptr2);
+ }
objPtr->typePtr = NULL;
}
@@ -4648,7 +4651,7 @@ DupNsNameInternalRep(
copyPtr->internalRep.twoPtrValue.ptr1 = resNamePtr;
copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
resNamePtr->refCount++;
- copyPtr->typePtr = &nsNameType;
+ copyPtr->typePtr = &tclNsNameType;
}
/*
@@ -4684,6 +4687,7 @@ SetNsNameFromAny(
Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr;
register ResolvedNsName *resNamePtr;
const char *name;
+ void *stringIntRep = NULL;
if (interp == NULL) {
return TCL_ERROR;
@@ -4705,7 +4709,7 @@ SetNsNameFromAny(
* it, nor time determining its invalidity again and again.
*/
- if (objPtr->typePtr == &nsNameType) {
+ if (objPtr->typePtr == &tclNsNameType) {
TclFreeIntRep(objPtr);
objPtr->typePtr = NULL;
}
@@ -4721,10 +4725,15 @@ SetNsNameFromAny(
resNamePtr->refNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
}
resNamePtr->refCount = 1;
+ /* If previous objType was string, keep the internal representation */
+ if (objPtr->typePtr == &tclStringType) {
+ stringIntRep = objPtr->internalRep.twoPtrValue.ptr2;
+ objPtr->internalRep.twoPtrValue.ptr2 = NULL;
+ }
TclFreeIntRep(objPtr);
objPtr->internalRep.twoPtrValue.ptr1 = resNamePtr;
- objPtr->internalRep.twoPtrValue.ptr2 = NULL;
- objPtr->typePtr = &nsNameType;
+ objPtr->internalRep.twoPtrValue.ptr2 = stringIntRep;
+ objPtr->typePtr = &tclNsNameType;
return TCL_OK;
}
@@ -6423,6 +6432,11 @@ MakeCachedEnsembleCommand(
}
ckfree(ensembleCmd->fullSubcmdName);
} else {
+ /* If previous objType was string, keep the internal representation */
+ if (objPtr->typePtr == &tclStringType) {
+ stringIntRep = objPtr->internalRep.twoPtrValue.ptr2;
+ objPtr->internalRep.twoPtrValue.ptr2 = NULL;
+ }
/*
* Kill the old internal rep, and replace it with a brand new one of
* our own.
diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c
index 23dbc68..22e89d9 100644
--- a/generic/tclPathObj.c
+++ b/generic/tclPathObj.c
@@ -35,7 +35,7 @@ static int MakePathFromNormalized(Tcl_Interp *interp,
* internally.
*/
-static Tcl_ObjType tclFsPathType = {
+Tcl_ObjType tclFsPathType = {
"path", /* name */
FreeFsPathInternalRep, /* freeIntRepProc */
DupFsPathInternalRep, /* dupIntRepProc */
@@ -2586,6 +2586,9 @@ FreeFsPathInternalRep(
}
ckfree((char *) fsPathPtr);
+ if (pathPtr->internalRep.twoPtrValue.ptr2) {
+ ckfree(pathPtr->internalRep.twoPtrValue.ptr2);
+ }
pathPtr->typePtr = NULL;
}
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 54a82b6..87d1aec 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -401,8 +401,16 @@ Tcl_GetCharLength(
String *stringPtr;
if ((objPtr->typePtr == &tclByteArrayType) ||
+ (objPtr->typePtr == &tclByteCodeType) ||
(objPtr->typePtr == &tclDictType) ||
- (objPtr->typePtr == &tclListType)) {
+ (objPtr->typePtr == &tclEncodingType) ||
+ (objPtr->typePtr == &tclEndOffsetType) ||
+ (objPtr->typePtr == &tclExprCodeType) ||
+ (objPtr->typePtr == &tclFsPathType) ||
+ (objPtr->typePtr == &tclIndexType) ||
+ /*(objPtr->typePtr == &tclListType) || This one causes cmdIL-1.29 failure */
+ (objPtr->typePtr == &tclNsNameType) ||
+ (objPtr->typePtr == &tclProcBodyType)) {
/* Try to convert object to String type, but remember old intRep. */
int length;
Tcl_ObjType *prevtype = objPtr->typePtr;
diff --git a/library/auto.tcl b/library/auto.tcl
index 55fc90f..b0fb61d 100644
--- a/library/auto.tcl
+++ b/library/auto.tcl
@@ -20,19 +20,20 @@
# 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}
rename $fqcn {}
}
}
- unset -nocomplain ::auto_execs ::auto_index ::tcl::auto_oldpath
- if {[catch {llength $::auto_path}]} {
- set ::auto_path [list [info library]]
+ unset -nocomplain auto_execs auto_index ::tcl::auto_oldpath
+ if {[catch {llength $auto_path}]} {
+ set auto_path [list [info library]]
} else {
- if {[info library] ni $::auto_path} {
- lappend ::auto_path [info library]
+ if {[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 {}
@@ -86,10 +87,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"} {
+ 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 1e7e2cd..21e0370 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 {
@@ -235,7 +237,7 @@ 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 the command word has the form "namespace inscope ns cmd"
# then concatenate its arguments onto the end and evaluate it.
@@ -250,8 +252,8 @@ proc unknown args {
return -options $opts $result
}
- catch {set savedErrorInfo $::errorInfo}
- catch {set savedErrorCode $::errorCode}
+ catch {set savedErrorInfo $errorInfo}
+ catch {set savedErrorCode $errorCode}
set name $cmd
if {![info exists auto_noload]} {
#
@@ -280,9 +282,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} {
@@ -291,8 +293,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]
@@ -309,7 +311,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.
@@ -324,18 +326,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
@@ -344,7 +346,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]
@@ -797,7 +799,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"
}
@@ -805,7 +807,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\
@@ -825,8 +827,8 @@ 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
diff --git a/library/package.tcl b/library/package.tcl
index 3831822..06f619c 100644
--- a/library/package.tcl
+++ b/library/package.tcl
@@ -389,9 +389,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} {
# $use_path. 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
}
}
@@ -632,8 +629,7 @@ proc tcl::MacOSXPkgUnknown {original name args} {
# $use_path. 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
}
}
@@ -685,10 +681,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} {
@@ -736,12 +729,7 @@ 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
- }
+ lassign $filespec filename proclist
if { [llength $proclist] == 0 } {
set cmd "\[list $key \[file join \$dir [list $filename]\]\]"
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 c5db437..baa268d 100644
--- a/library/tm.tcl
+++ b/library/tm.tcl
@@ -58,7 +58,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 --
@@ -273,10 +273,8 @@ proc ::tcl::tm::UnknownHandler {original name args} {
# 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 scripts for every candidate in the
@@ -359,7 +357,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 1ca1c9b..f07d466 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::*
testConstraint testgetassocdata [llength [info commands testgetassocdata]]
testConstraint testsetassocdata [llength [info commands testsetassocdata]]
@@ -57,5 +55,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 318e5c4..0bad4ed 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::*
testConstraint testevalex [llength [info commands testevalex]]
testConstraint testcmdtoken [llength [info commands testcmdtoken]]
@@ -28,7 +28,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}
@@ -299,7 +299,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
@@ -352,7 +352,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 {} {
@@ -424,7 +424,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
@@ -544,8 +544,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}
@@ -967,6 +967,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 86aa6e1..112318f 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::*
testConstraint testcmdinfo [llength [info commands testcmdinfo]]
testConstraint testcmdtoken [llength [info commands testcmdtoken]]
@@ -98,7 +96,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 8977c31..d604c06 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::*
testConstraint testdcall [llength [info commands testdcall]]
@@ -38,5 +36,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 c05a925..2b90a92 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::*
testConstraint testexprlong [llength [info commands testexprlong]]
testConstraint testexprdouble [llength [info commands testexprdouble]]
@@ -142,7 +140,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}]
@@ -450,7 +448,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} {
@@ -499,7 +497,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}}
@@ -578,7 +576,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 cdd3b17..324b594 100644
--- a/tests/main.test
+++ b/tests/main.test
@@ -137,7 +137,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]"
@@ -158,7 +158,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]"
@@ -179,7 +179,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]"
@@ -600,7 +600,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
@@ -614,19 +614,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
@@ -639,17 +639,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
@@ -756,7 +756,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
@@ -991,7 +991,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 0edb1d2..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]
@@ -655,7 +655,6 @@ namespace eval ::msgcat::test {
removeFile l2.msg $msgdir2
removeDirectory msgdir2
- removeFile l3.msg $msgdir3
removeDirectory msgdir3
cleanupTests
diff --git a/tests/parse.test b/tests/parse.test
index 37c44d5..4605914 100644
--- a/tests/parse.test
+++ b/tests/parse.test
@@ -435,7 +435,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 {} {
@@ -476,7 +476,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 {
@@ -484,21 +484,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 {
@@ -538,11 +538,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 {
@@ -561,7 +561,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 {
@@ -667,11 +667,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"}}
diff --git a/tests/parseExpr.test b/tests/parseExpr.test
index 29d8c9f..c1c489b 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::*
# Note that the Tcl expression parser (tclCompExpr.c) does not check
# the semantic validity of the expressions it parses. It does not check,
@@ -1055,5 +1053,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 132481c..c8f82cf 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::*
testConstraint testwordend [llength [info commands testwordend]]
@@ -163,25 +161,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} {
@@ -191,9 +189,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 \
@@ -208,13 +206,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 663a6b2..990bb5f 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]
@@ -46,7 +44,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]
}
@@ -82,7 +80,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]
@@ -112,9 +110,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 4f1eb82..ab82d07 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
testConstraint testCPUID [llength [info commands testcpuid]]
@@ -51,7 +55,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 3ee803e..22419e3 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::*
# Some tests require the testsaveresult command
diff --git a/tests/stack.test b/tests/stack.test
index 96bcb98..62c3e98 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 results in a crash of the executable.
# In order to avoid that, we do a basic check of the current stacksize.
diff --git a/tests/tcltest.test b/tests/tcltest.test
index 86aca6f..ce8d617 100644
--- 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/tm.test b/tests/tm.test
index f6c9a68..3f93483 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 b1202b8..9c3a686 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::*
testConstraint testcmdtrace [llength [info commands testcmdtrace]]
testConstraint testevalobjv [llength [info commands testevalobjv]]
@@ -29,15 +27,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
@@ -59,7 +57,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
@@ -69,10 +67,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}}
@@ -80,40 +78,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 {} {
@@ -124,7 +122,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} {
@@ -141,20 +139,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
@@ -162,28 +160,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 ;#}
@@ -193,28 +191,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
@@ -222,7 +220,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
@@ -235,7 +233,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
@@ -264,7 +262,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
@@ -273,7 +271,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
@@ -284,14 +282,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
@@ -299,7 +297,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
@@ -307,15 +305,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
@@ -323,7 +321,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
@@ -331,15 +329,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
@@ -349,7 +347,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
@@ -361,7 +359,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 {}
@@ -369,7 +367,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 {}
@@ -378,7 +376,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
@@ -387,19 +385,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 {}
@@ -407,14 +405,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}
@@ -422,7 +420,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}
@@ -433,7 +431,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)}
@@ -445,7 +443,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)}
@@ -460,7 +458,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"
@@ -471,7 +469,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"
@@ -481,7 +479,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"
@@ -497,7 +495,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"
@@ -505,7 +503,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"
@@ -513,14 +511,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"
@@ -528,7 +526,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"
@@ -538,7 +536,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
@@ -547,7 +545,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}
@@ -568,7 +566,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} {
@@ -582,31 +580,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}}
@@ -615,23 +613,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)}}
@@ -639,49 +637,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 {}}}
@@ -689,7 +687,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}}
@@ -700,52 +698,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}}
@@ -759,7 +757,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}
@@ -913,13 +911,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
@@ -927,7 +925,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
@@ -942,7 +940,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
@@ -950,27 +948,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}
@@ -980,7 +978,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 \
@@ -998,14 +996,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
@@ -1017,18 +1015,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
@@ -1036,7 +1034,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}
@@ -1044,49 +1042,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}
@@ -1094,91 +1092,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}
@@ -1188,7 +1186,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}
@@ -1201,19 +1199,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
@@ -1226,7 +1224,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
@@ -1266,8 +1264,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!
@@ -1539,8 +1536,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).
@@ -2047,7 +2043,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
@@ -2631,9 +2627,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 003dd00..1014d52 100644
--- a/tests/unixInit.test
+++ b/tests/unixInit.test
@@ -11,7 +11,7 @@
# of 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
@@ -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
@@ -343,7 +343,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
@@ -356,7 +356,7 @@ test unixInit-3.2 {TclpSetInitialEncodings} {unix stdio} {
catch {set oldlc_all $env(LC_ALL)}
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
@@ -403,7 +403,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 69a468f..99b17b8 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} {
@@ -61,5 +59,5 @@ test unknown-4.1 {errors in "unknown" procedure} {
# cleanup
catch {rename unknown {}}
catch {rename unknown.old unknown}
-::tcltest::cleanupTests
+cleanupTests
return
diff --git a/unix/Makefile.in b/unix/Makefile.in
index 3daad96..2f64602 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -778,8 +778,8 @@ install-libraries: libraries $(INSTALL_TZDATA) install-msgs
@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;
diff --git a/win/Makefile.in b/win/Makefile.in
index ff3a511..e61fed8 100644
--- a/win/Makefile.in
+++ b/win/Makefile.in
@@ -653,8 +653,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";