From a9377a35b758968f62531271a5d5978ee9d8645a Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 5 Jun 2023 11:12:08 +0000 Subject: Added note about how some commands are mainly for Tk --- doc/library.n | 3 +++ 1 file changed, 3 insertions(+) diff --git a/doc/library.n b/doc/library.n index 64252f3..fb43364 100644 --- a/doc/library.n +++ b/doc/library.n @@ -248,6 +248,9 @@ For example, to print the contents of the \fBtcl_platform\fR array, do: \fBparray\fR tcl_platform .CE .RE +.SS "WORD BOUNDARY HELPERS" +.PP +These procedures are mainly used internally by Tk. .TP \fBtcl_endOfWord \fIstr start\fR . -- cgit v0.12 From 96c8069270e5e13c9f963decd8c7f17f3df54a00 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 8 Jun 2023 11:59:30 +0000 Subject: (cherry-pick): Added note about how some commands are mainly for Tk --- doc/library.n | 3 +++ 1 file changed, 3 insertions(+) diff --git a/doc/library.n b/doc/library.n index 87f13bd..f14e8e0 100644 --- a/doc/library.n +++ b/doc/library.n @@ -203,6 +203,9 @@ matching rules of \fBstring match\fR) and their values if \fIpattern\fR is given. \fIArrayName\fR must be an array accessible to the caller of \fBparray\fR. It may be either local or global. +.SS "WORD BOUNDARY HELPERS" +.PP +These procedures are mainly used internally by Tk. .TP \fBtcl_endOfWord \fIstr start\fR Returns the index of the first end-of-word location that occurs after -- cgit v0.12 From 9cf727affb1f44a61c77f90a48c92b3a70e6d8b4 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 11 Jun 2023 02:34:35 +0000 Subject: Tests for invalidly encoded file names and env (TIP 671 motivation) --- tests/env.test | 21 +++++++++++++++++++++ tests/fileName.test | 22 +++++++++++++++++++++- 2 files changed, 42 insertions(+), 1 deletion(-) diff --git a/tests/env.test b/tests/env.test index 7debb2f..345567b 100644 --- a/tests/env.test +++ b/tests/env.test @@ -18,6 +18,11 @@ if {"::tcltest" ni [namespace children]} { source [file join [file dirname [info script]] tcltests.tcl] +testConstraint utf8system [string equal [encoding system] utf-8] +if {[llength [auto_execok bash]]} { + testConstraint haveBash 1 +} + # [exec] is required here to see the actual environment received by child # processes. proc getenv {} { @@ -508,6 +513,22 @@ test env-9.1 { } } -result {} +test env-10.0 { + Unequal environment strings test should test unequal +} -constraints {unix haveBash utf8system knownBug} -setup { + set tclScript [makeFile { + puts [string equal $env(XX) $env(YY)] + } tclScript] + set shellCode { + export XX=$'\351' + export YY=$'\303\251' + } + append shellCode "[info nameofexecutable] $tclScript\n" + set shScript [makeFile $shellCode shScript] +} -body { + exec {*}[auto_execok bash] $shScript +} -result 0 + # cleanup diff --git a/tests/fileName.test b/tests/fileName.test index be424e2..46f1c5e 100644 --- a/tests/fileName.test +++ b/tests/fileName.test @@ -1610,7 +1610,27 @@ test fileName-20.10 {globbing for special chars} -setup { removeFile fileName-20.10 $s removeDirectory sub [file home] } -result [file home]/sub/fileName-20.10 - +test fileName-20.11 {glob dir with undecodable file names} -setup { + # Specifically use /tmp as on WSL [temporaryDirectory] + # on NTFS prevents creation of arbitrary byte sequences in names. + set prevDir [pwd] + set testDir /tmp/tcltest/fileName-20.11 + file delete -force $testDir; # Clear it + file mkdir $testDir + cd $testDir + set prevEnc [encoding system] + # Create a file name that is invalid if interpreted as utf-8 + encoding system iso8859-1 + close [open \xe9 w] +} -cleanup { + encoding system $prevEnc + cd $prevDir + file delete -force $testDir +} -constraints {unix knownBug} -body { + set result [file exists [lindex [glob *] 0]] + encoding system utf-8 + lappend result [file exists [lindex [glob *] 0]] +} -result {1 1} apply [list {} { test fileName-6d4e9d1af5bf5b7d { -- cgit v0.12 From d07e50e54a59bd0355c5fa01c44ef95b1677835c Mon Sep 17 00:00:00 2001 From: pooryorick Date: Mon, 12 Jun 2023 04:10:52 +0000 Subject: Revert unwarranted change in Tcl_CreateChannel() from [1776327edd]. --- generic/tclIO.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 4d327b3..0c91428 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -1681,11 +1681,11 @@ Tcl_CreateChannel( statePtr->inputEncodingState = NULL; statePtr->inputEncodingFlags = TCL_ENCODING_START; ENCODING_PROFILE_SET(statePtr->inputEncodingFlags, - TCL_ENCODING_PROFILE_TCL8); + TCL_ENCODING_PROFILE_DEFAULT); statePtr->outputEncodingState = NULL; statePtr->outputEncodingFlags = TCL_ENCODING_START; ENCODING_PROFILE_SET(statePtr->outputEncodingFlags, - TCL_ENCODING_PROFILE_TCL8); + TCL_ENCODING_PROFILE_DEFAULT); /* * Set the channel up initially in AUTO input translation mode to accept -- cgit v0.12 From 3c8ac03074fc97f5cacb7163698d37faa4c2f07e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 13 Jun 2023 06:05:02 +0000 Subject: Specify implicit "-profile tcl8" in encoding-24.4 testcase --- tests/encoding.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/encoding.test b/tests/encoding.test index eb91a1d..c404eb0 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -765,7 +765,7 @@ test encoding-24.3 {EscapeFreeProc on open channels} {stdio} { } [list 3 "乎乞也 (\\u4E4E\\u4E5E\\u4E5F)"] test encoding-24.4 {Parse valid or invalid utf-8} { - string length [encoding convertfrom utf-8 "\xC0\x80"] + string length [encoding convertfrom -profile tcl8 utf-8 "\xC0\x80"] } 1 test encoding-24.5 {Parse valid or invalid utf-8} { string length [encoding convertfrom -profile tcl8 utf-8 "\xC0\x81"] -- cgit v0.12 From cf84dd6daf65e20f747bcabb9584b370c08f4392 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 16 Jun 2023 12:21:21 +0000 Subject: Proposed fix for [c13819225e]: Problem with lsort|lsearch -stride on 32-bit linux. Also fix some compiler warnings --- generic/tclBinary.c | 2 +- generic/tclCmdIL.c | 15 ++++++++------- generic/tclIOUtil.c | 8 ++++---- generic/tclVar.c | 4 ++-- 4 files changed, 15 insertions(+), 14 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 81ea3f3..b8cf1bc 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -2629,7 +2629,7 @@ BinaryEncode64( } switch (index) { case OPT_MAXLEN: - if (Tcl_GetSizeIntFromObj(interp, objv[i + 1], &maxlen) != TCL_OK) { + if (TclGetSizeIntFromObj(interp, objv[i + 1], &maxlen) != TCL_OK) { return TCL_ERROR; } if (maxlen < 0) { diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 4836b9e..9a502e0 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -2981,7 +2981,8 @@ Tcl_LrepeatObjCmd( Tcl_Obj *const objv[]) /* The argument objects. */ { - Tcl_Size elementCount, i, totalElems; + Tcl_WideInt elementCount, i; + Tcl_Size totalElems; Tcl_Obj *listPtr, **dataArray = NULL; /* @@ -2993,12 +2994,12 @@ Tcl_LrepeatObjCmd( Tcl_WrongNumArgs(interp, 1, objv, "count ?value ...?"); return TCL_ERROR; } - if (TCL_OK != TclGetSizeIntFromObj(interp, objv[1], &elementCount)) { + if (TCL_OK != TclGetWideIntFromObj(interp, objv[1], &elementCount)) { return TCL_ERROR; } if (elementCount < 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad count \"%" TCL_SIZE_MODIFIER "d\": must be integer >= 0", elementCount)); + "bad count \"%" TCL_LL_MODIFIER "d\": must be integer >= 0", elementCount)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LREPEAT", "NEGARG", NULL); return TCL_ERROR; @@ -3307,10 +3308,10 @@ Tcl_LsearchObjCmd( const char *bytes, *patternBytes; int match, result=TCL_OK, bisect; Tcl_Size i, length = 0, listc, elemLen, start, index; - Tcl_Size groupSize, groupOffset, lower, upper; + Tcl_Size groupOffset, lower, upper; int allocatedIndexVector = 0; int isIncreasing; - Tcl_WideInt patWide, objWide, wide; + Tcl_WideInt patWide, objWide, wide, groupSize; int allMatches, inlineReturn, negatedMatch, returnSubindices, noCase; double patDouble, objDouble; SortInfo sortInfo; @@ -4554,8 +4555,8 @@ Tcl_LsortObjCmd( int indices, nocase = 0, indexc; int sortMode = SORTMODE_ASCII; int group, allocatedIndexVector = 0; - Tcl_Size j, idx, groupSize, groupOffset, length; - Tcl_WideInt wide; + Tcl_Size j, idx, groupOffset, length; + Tcl_WideInt wide, groupSize; Tcl_Obj *resultPtr, *cmdPtr, **listObjPtrs, *listObj, *indexPtr; Tcl_Size i, elmArrSize; SortElement *elementArray = NULL, *elementPtr; diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index cec6ad3..4484e2b 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -1802,7 +1802,7 @@ Tcl_FSEvalFileEx( const char *pathString = Tcl_GetStringFromObj(pathPtr, &length); unsigned limit = 150; - int overflow = (length > limit); + int overflow = ((unsigned)length > limit); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (file \"%.*s%s\" line %d)", @@ -1954,12 +1954,12 @@ EvalFileCallback( Tcl_Size length; const char *pathString = Tcl_GetStringFromObj(pathPtr, &length); - const unsigned int limit = 150; - int overflow = (length > limit); + const unsigned limit = 150; + int overflow = ((unsigned)length > limit); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (file \"%.*s%s\" line %d)", - (overflow ? limit : (unsigned int)length), pathString, + (overflow ? limit : (unsigned)length), pathString, (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); } diff --git a/generic/tclVar.c b/generic/tclVar.c index 32ee631..3bd47be 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -376,7 +376,7 @@ CleanupVar( { if (TclIsVarUndefined(varPtr) && TclIsVarInHash(varPtr) && !TclIsVarTraced(varPtr) - && (VarHashRefCount(varPtr) == (unsigned) + && (VarHashRefCount(varPtr) == (Tcl_Size) !TclIsVarDeadHash(varPtr))) { if (VarHashRefCount(varPtr) == 0) { Tcl_Free(varPtr); @@ -386,7 +386,7 @@ CleanupVar( } if (arrayPtr != NULL && TclIsVarUndefined(arrayPtr) && TclIsVarInHash(arrayPtr) && !TclIsVarTraced(arrayPtr) && - (VarHashRefCount(arrayPtr) == (unsigned) + (VarHashRefCount(arrayPtr) == (Tcl_Size) !TclIsVarDeadHash(arrayPtr))) { if (VarHashRefCount(arrayPtr) == 0) { Tcl_Free(arrayPtr); -- cgit v0.12 From ec8dfd57db4d9f4cfdef1f38109a55addf6c030a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 19 Jun 2023 11:47:58 +0000 Subject: Some more Tcl_Size usage --- generic/tclVar.c | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/generic/tclVar.c b/generic/tclVar.c index e79bfc1..ea8a104 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -379,7 +379,8 @@ CleanupVar( { if (TclIsVarUndefined(varPtr) && TclIsVarInHash(varPtr) && !TclIsVarTraced(varPtr) - && (VarHashRefCount(varPtr) == !TclIsVarDeadHash(varPtr))) { + && (VarHashRefCount(varPtr) == (Tcl_Size) + !TclIsVarDeadHash(varPtr))) { if (VarHashRefCount(varPtr) == 0) { ckfree(varPtr); } else { @@ -388,7 +389,8 @@ CleanupVar( } if (arrayPtr != NULL && TclIsVarUndefined(arrayPtr) && TclIsVarInHash(arrayPtr) && !TclIsVarTraced(arrayPtr) && - (VarHashRefCount(arrayPtr) == !TclIsVarDeadHash(arrayPtr))) { + (VarHashRefCount(arrayPtr) == (Tcl_Size) + !TclIsVarDeadHash(arrayPtr))) { if (VarHashRefCount(arrayPtr) == 0) { ckfree(arrayPtr); } else { @@ -5602,7 +5604,7 @@ TclDeleteCompiledLocalVars( * assigned local variables to delete. */ { Var *varPtr; - size_t numLocals, i; + Tcl_Size numLocals, i; Tcl_Obj **namePtrPtr; numLocals = framePtr->numCompiledLocals; -- cgit v0.12 From c2f255fe8425a37da1e023267829f7d497c9a219 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Mon, 19 Jun 2023 12:49:29 +0000 Subject: Fix hardcoded port numbers causing Windows failures with hyperv. Disable file perm test for WSL. --- tests/chanio.test | 11 ++++++----- tests/io.test | 17 ++++++++++------- 2 files changed, 16 insertions(+), 12 deletions(-) diff --git a/tests/chanio.test b/tests/chanio.test index 6062605..3452f78 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -7219,22 +7219,23 @@ test chan-io-53.10 {Bug 1350564, multi-directional fcopy} -setup { } chan puts stderr SRV set l {} - set srv [socket -server new 9999] + set srv [socket -server new -myaddr 127.0.0.1 0] + set port [lindex [chan configure $srv -sockname] 2] chan puts stderr WAITING chan event stdin readable bye - chan puts OK + puts "OK $port" vwait forever } # wait for OK from server. - chan gets $pipe + lassign [chan gets $pipe] ok port # Now the two clients. proc done {sock} { if {[chan eof $sock]} { chan close $sock ; return } lappend ::forever [chan gets $sock] return } - set a [socket 127.0.0.1 9999] - set b [socket 127.0.0.1 9999] + set a [socket 127.0.0.1 $port] + set b [socket 127.0.0.1 $port] chan configure $a -translation binary -buffering none chan configure $b -translation binary -buffering none chan event $a readable [namespace code "done $a"] diff --git a/tests/io.test b/tests/io.test index 031f857..d20bc87 100644 --- a/tests/io.test +++ b/tests/io.test @@ -48,6 +48,8 @@ testConstraint testservicemode [llength [info commands testservicemode]] testConstraint notWinCI [expr { $::tcl_platform(platform) ne "windows" || ![info exists ::env(CI)]}] testConstraint notOSX [expr {$::tcl_platform(os) ne "Darwin"}] +# File permissions broken on wsl without some "exotic" wsl configuration +testConstraint notWsl [expr {[llength [array names ::env *WSL*]] == 0}] # You need a *very* special environment to do some tests. In # particular, many file systems do not support large-files... @@ -5752,7 +5754,7 @@ test io-40.1 {POSIX open access modes: RDWR} { close $f set x } {zzy abzzy} -test io-40.2 {POSIX open access modes: CREAT} {unix} { +test io-40.2 {POSIX open access modes: CREAT} {unix notWsl} { file delete $path(test3) set f [open $path(test3) {WRONLY CREAT} 0o600] file stat $path(test3) stats @@ -5764,7 +5766,7 @@ test io-40.2 {POSIX open access modes: CREAT} {unix} { close $f set x } {0o600 {line 1}} -test io-40.3 {POSIX open access modes: CREAT} {unix umask} { +test io-40.3 {POSIX open access modes: CREAT} {unix umask notWsl} { # This test only works if your umask is 2, like ouster's. file delete $path(test3) set f [open $path(test3) {WRONLY CREAT}] @@ -7912,22 +7914,23 @@ test io-53.10 {Bug 1350564, multi-directional fcopy} -setup { } puts stderr SRV set l {} - set srv [socket -server new 9999] + set srv [socket -server new -myaddr 127.0.0.1 0] + set port [lindex [fconfigure $srv -sockname] 2] puts stderr WAITING fileevent stdin readable bye - puts OK + puts "OK $port" vwait forever } # wait for OK from server. - gets $pipe + lassign [gets $pipe] ok port # Now the two clients. proc ::done {sock} { if {[eof $sock]} { close $sock ; return } lappend ::forever [gets $sock] return } - set a [socket 127.0.0.1 9999] - set b [socket 127.0.0.1 9999] + set a [socket 127.0.0.1 $port] + set b [socket 127.0.0.1 $port] fconfigure $a -translation binary -buffering none fconfigure $b -translation binary -buffering none fileevent $a readable [list ::done $a] -- cgit v0.12 From 104527a10755e3d38008d55cc79bd8f76ce4d9e8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 20 Jun 2023 06:51:49 +0000 Subject: Move VarHashGetKey() to tclInt.h. More int -> Tcl_Size --- generic/tclDisassemble.c | 100 +++++++++++++++++++++++------------------------ generic/tclInt.h | 16 +++++--- generic/tclNamesp.c | 81 ++++++++++++++++++++------------------ generic/tclProc.c | 22 +++++------ generic/tclVar.c | 9 ++--- 5 files changed, 116 insertions(+), 112 deletions(-) diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 72c5bc8..2bbfc40 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -28,7 +28,7 @@ static int FormatInstruction(ByteCode *codePtr, static void GetLocationInformation(Proc *procPtr, Tcl_Obj **fileObjPtr, int *linePtr); static void PrintSourceToObj(Tcl_Obj *appendObj, - const char *stringPtr, int maxChars); + const char *stringPtr, Tcl_Size maxChars); static void UpdateStringOfInstName(Tcl_Obj *objPtr); /* @@ -193,10 +193,10 @@ TclPrintObject( FILE *outFile, /* The file to print the source to. */ Tcl_Obj *objPtr, /* Points to the Tcl object whose string * representation should be printed. */ - int maxChars) /* Maximum number of chars to print. */ + Tcl_Size maxChars) /* Maximum number of chars to print. */ { char *bytes; - int length; + Tcl_Size length; bytes = TclGetStringFromObj(objPtr, &length); TclPrintSource(outFile, bytes, TclMin(length, maxChars)); @@ -224,7 +224,7 @@ void TclPrintSource( FILE *outFile, /* The file to print the source to. */ const char *stringPtr, /* The string to print. */ - int maxChars) /* Maximum number of chars to print. */ + Tcl_Size maxChars) /* Maximum number of chars to print. */ { Tcl_Obj *bufferObj; @@ -255,7 +255,8 @@ DisassembleByteCodeObj( unsigned char *codeStart, *codeLimit, *pc; unsigned char *codeDeltaNext, *codeLengthNext; unsigned char *srcDeltaNext, *srcLengthNext; - int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i, line; + int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, line; + Tcl_Size i; Interp *iPtr; Tcl_Obj *bufferObj, *fileObj; @@ -277,9 +278,8 @@ DisassembleByteCodeObj( */ Tcl_AppendPrintfToObj(bufferObj, - "ByteCode %p, refCt %u, epoch %u, interp %p (epoch %u)\n", - codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr, - iPtr->compileEpoch); + "ByteCode %p, refCt %" TCL_SIZE_MODIFIER "u, epoch %" TCL_SIZE_MODIFIER "u, interp %p (epoch %" TCL_SIZE_MODIFIER "u)\n", + codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr, iPtr->compileEpoch); Tcl_AppendToObj(bufferObj, " Source ", -1); PrintSourceToObj(bufferObj, codePtr->source, TclMin(codePtr->numSrcBytes, 55)); @@ -289,7 +289,7 @@ DisassembleByteCodeObj( TclGetString(fileObj), line); } Tcl_AppendPrintfToObj(bufferObj, - "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", + "\n Cmds %d, src %" TCL_SIZE_MODIFIER "u, inst %" TCL_SIZE_MODIFIER "u, litObjs %" TCL_SIZE_MODIFIER "u, aux %" TCL_SIZE_MODIFIER "u, stkDepth %" TCL_SIZE_MODIFIER "u, code/src %.2f\n", numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes, codePtr->numLitObjects, codePtr->numAuxDataItems, codePtr->maxStackDepth, @@ -301,8 +301,8 @@ DisassembleByteCodeObj( #ifdef TCL_COMPILE_STATS Tcl_AppendPrintfToObj(bufferObj, - " Code %" TCL_Z_MODIFIER "u = header %" TCL_Z_MODIFIER "u+inst %d+litObj %" - TCL_Z_MODIFIER "u+exc %" TCL_Z_MODIFIER "u+aux %" TCL_Z_MODIFIER "u+cmdMap %d\n", + " Code %" TCL_Z_MODIFIER "u = header %" TCL_Z_MODIFIER "u+inst %" TCL_SIZE_MODIFIER "u+litObj %" + TCL_Z_MODIFIER "u+exc %" TCL_Z_MODIFIER "u+aux %" TCL_Z_MODIFIER "u+cmdMap %" TCL_SIZE_MODIFIER "u\n", codePtr->structureSize, offsetof(ByteCode, localCachePtr), codePtr->numCodeBytes, @@ -320,10 +320,10 @@ DisassembleByteCodeObj( if (codePtr->procPtr != NULL) { Proc *procPtr = codePtr->procPtr; - int numCompiledLocals = procPtr->numCompiledLocals; + Tcl_Size numCompiledLocals = procPtr->numCompiledLocals; Tcl_AppendPrintfToObj(bufferObj, - " Proc %p, refCt %u, args %d, compiled locals %d\n", + " Proc %p, refCt %" TCL_SIZE_MODIFIER "u, args %" TCL_SIZE_MODIFIER "u, compiled locals %" TCL_SIZE_MODIFIER "u\n", procPtr, procPtr->refCount, procPtr->numArgs, numCompiledLocals); if (numCompiledLocals > 0) { @@ -331,7 +331,7 @@ DisassembleByteCodeObj( for (i = 0; i < numCompiledLocals; i++) { Tcl_AppendPrintfToObj(bufferObj, - " slot %d%s%s%s%s%s%s", i, + " slot %" TCL_SIZE_MODIFIER "u%s%s%s%s%s%s", i, (localPtr->flags & (VAR_ARRAY|VAR_LINK)) ? "" : ", scalar", (localPtr->flags & VAR_ARRAY) ? ", array" : "", (localPtr->flags & VAR_LINK) ? ", link" : "", @@ -354,24 +354,24 @@ DisassembleByteCodeObj( */ if (codePtr->numExceptRanges > 0) { - Tcl_AppendPrintfToObj(bufferObj, " Exception ranges %d, depth %d:\n", + Tcl_AppendPrintfToObj(bufferObj, " Exception ranges %" TCL_SIZE_MODIFIER "u, depth %" TCL_SIZE_MODIFIER "u:\n", codePtr->numExceptRanges, codePtr->maxExceptDepth); for (i = 0; i < codePtr->numExceptRanges; i++) { ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i]; Tcl_AppendPrintfToObj(bufferObj, - " %d: level %d, %s, pc %d-%d, ", + " %" TCL_SIZE_MODIFIER "u: level %" TCL_SIZE_MODIFIER "u, %s, pc %" TCL_SIZE_MODIFIER "u-%" TCL_SIZE_MODIFIER "u, ", i, rangePtr->nestingLevel, (rangePtr->type==LOOP_EXCEPTION_RANGE ? "loop" : "catch"), rangePtr->codeOffset, (rangePtr->codeOffset + rangePtr->numCodeBytes - 1)); switch (rangePtr->type) { case LOOP_EXCEPTION_RANGE: - Tcl_AppendPrintfToObj(bufferObj, "continue %d, break %d\n", + Tcl_AppendPrintfToObj(bufferObj, "continue %" TCL_SIZE_MODIFIER "u, break %" TCL_SIZE_MODIFIER "u\n", rangePtr->continueOffset, rangePtr->breakOffset); break; case CATCH_EXCEPTION_RANGE: - Tcl_AppendPrintfToObj(bufferObj, "catch %d\n", + Tcl_AppendPrintfToObj(bufferObj, "catch %" TCL_SIZE_MODIFIER "u\n", rangePtr->catchOffset); break; default: @@ -407,7 +407,7 @@ DisassembleByteCodeObj( srcLengthNext = codePtr->srcLengthStart; codeOffset = srcOffset = 0; for (i = 0; i < numCmds; i++) { - if ((unsigned) *codeDeltaNext == (unsigned) 0xFF) { + if (*codeDeltaNext == 0xFF) { codeDeltaNext++; delta = TclGetInt4AtPtr(codeDeltaNext); codeDeltaNext += 4; @@ -417,7 +417,7 @@ DisassembleByteCodeObj( } codeOffset += delta; - if ((unsigned) *codeLengthNext == (unsigned) 0xFF) { + if (*codeLengthNext == 0xFF) { codeLengthNext++; codeLen = TclGetInt4AtPtr(codeLengthNext); codeLengthNext += 4; @@ -426,7 +426,7 @@ DisassembleByteCodeObj( codeLengthNext++; } - if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) { + if (*srcDeltaNext == 0xFF) { srcDeltaNext++; delta = TclGetInt4AtPtr(srcDeltaNext); srcDeltaNext += 4; @@ -436,7 +436,7 @@ DisassembleByteCodeObj( } srcOffset += delta; - if ((unsigned) *srcLengthNext == (unsigned) 0xFF) { + if (*srcLengthNext == 0xFF) { srcLengthNext++; srcLen = TclGetInt4AtPtr(srcLengthNext); srcLengthNext += 4; @@ -445,7 +445,7 @@ DisassembleByteCodeObj( srcLengthNext++; } - Tcl_AppendPrintfToObj(bufferObj, "%s%4d: pc %d-%d, src %d-%d", + Tcl_AppendPrintfToObj(bufferObj, "%s%4" TCL_SIZE_MODIFIER "u: pc %d-%d, src %d-%d", ((i % 2)? " " : "\n "), (i+1), codeOffset, (codeOffset + codeLen - 1), srcOffset, (srcOffset + srcLen - 1)); @@ -466,7 +466,7 @@ DisassembleByteCodeObj( codeOffset = srcOffset = 0; pc = codeStart; for (i = 0; i < numCmds; i++) { - if ((unsigned) *codeDeltaNext == (unsigned) 0xFF) { + if (*codeDeltaNext == 0xFF) { codeDeltaNext++; delta = TclGetInt4AtPtr(codeDeltaNext); codeDeltaNext += 4; @@ -476,7 +476,7 @@ DisassembleByteCodeObj( } codeOffset += delta; - if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) { + if (*srcDeltaNext == 0xFF) { srcDeltaNext++; delta = TclGetInt4AtPtr(srcDeltaNext); srcDeltaNext += 4; @@ -486,7 +486,7 @@ DisassembleByteCodeObj( } srcOffset += delta; - if ((unsigned) *srcLengthNext == (unsigned) 0xFF) { + if (*srcLengthNext == 0xFF) { srcLengthNext++; srcLen = TclGetInt4AtPtr(srcLengthNext); srcLengthNext += 4; @@ -504,7 +504,7 @@ DisassembleByteCodeObj( pc += FormatInstruction(codePtr, pc, bufferObj); } - Tcl_AppendPrintfToObj(bufferObj, " Command %d: ", i+1); + Tcl_AppendPrintfToObj(bufferObj, " Command %" TCL_SIZE_MODIFIER "u: ", i+1); PrintSourceToObj(bufferObj, (codePtr->source + srcOffset), TclMin(srcLen, 55)); Tcl_AppendToObj(bufferObj, "\n", -1); @@ -544,7 +544,7 @@ FormatInstruction( unsigned char *codeStart = codePtr->codeStart; unsigned pcOffset = pc - codeStart; int opnd = 0, i, j, numBytes = 1; - int localCt = procPtr ? procPtr->numCompiledLocals : 0; + Tcl_Size localCt = procPtr ? procPtr->numCompiledLocals : 0; CompiledLocal *localPtr = procPtr ? procPtr->firstLocalPtr : NULL; char suffixBuffer[128]; /* Additional info to print after main opcode * and immediates. */ @@ -566,7 +566,7 @@ FormatInstruction( break; case OPERAND_UINT1: opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; - Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); + Tcl_AppendPrintfToObj(bufferObj, "%u ", opnd); break; case OPERAND_UINT4: opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; @@ -574,7 +574,7 @@ FormatInstruction( snprintf(suffixBuffer+strlen(suffixBuffer), sizeof(suffixBuffer) - strlen(suffixBuffer), ", %u cmds start here", opnd); } - Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); + Tcl_AppendPrintfToObj(bufferObj, "%u ", opnd); break; case OPERAND_OFFSET1: opnd = TclGetInt1AtPtr(pc+numBytes); numBytes++; @@ -593,16 +593,16 @@ FormatInstruction( case OPERAND_LIT1: opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; suffixObj = codePtr->objArrayPtr[opnd]; - Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); + Tcl_AppendPrintfToObj(bufferObj, "%u ", opnd); break; case OPERAND_LIT4: opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; suffixObj = codePtr->objArrayPtr[opnd]; - Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); + Tcl_AppendPrintfToObj(bufferObj, "%u ", opnd); break; case OPERAND_AUX4: opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; - Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); + Tcl_AppendPrintfToObj(bufferObj, "%u ", opnd); auxPtr = &codePtr->auxDataArrayPtr[opnd]; break; case OPERAND_IDX4: @@ -625,20 +625,20 @@ FormatInstruction( printLVTindex: if (localPtr != NULL) { if (opnd >= localCt) { - Tcl_Panic("FormatInstruction: bad local var index %u (%u locals)", - (unsigned) opnd, localCt); + Tcl_Panic("FormatInstruction: bad local var index %u (%" TCL_SIZE_MODIFIER "u locals)", + opnd, localCt); } for (j = 0; j < opnd; j++) { localPtr = localPtr->nextPtr; } if (TclIsVarTemporary(localPtr)) { - snprintf(suffixBuffer, sizeof(suffixBuffer), "temp var %u", (unsigned) opnd); + snprintf(suffixBuffer, sizeof(suffixBuffer), "temp var %u", opnd); } else { snprintf(suffixBuffer, sizeof(suffixBuffer), "var "); suffixSrc = localPtr->name; } } - Tcl_AppendPrintfToObj(bufferObj, "%%v%u ", (unsigned) opnd); + Tcl_AppendPrintfToObj(bufferObj, "%%v%u ", opnd); break; case OPERAND_SCLS1: opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; @@ -652,7 +652,7 @@ FormatInstruction( } if (suffixObj) { const char *bytes; - int length; + Tcl_Size length; Tcl_AppendToObj(bufferObj, "\t# ", -1); bytes = TclGetStringFromObj(codePtr->objArrayPtr[opnd], &length); @@ -690,7 +690,7 @@ TclGetInnerContext( const unsigned char *pc, Tcl_Obj **tosPtr) { - int objc = 0, off = 0; + Tcl_Size objc = 0; Tcl_Obj *result; Interp *iPtr = (Interp *) interp; @@ -759,7 +759,7 @@ TclGetInnerContext( iPtr->innerContext = result = Tcl_NewListObj(objc + 1, NULL); Tcl_IncrRefCount(result); } else { - int len; + Tcl_Size len; /* * Reset while keeping the list internalrep as much as possible. @@ -773,7 +773,7 @@ TclGetInnerContext( for (; objc>0 ; objc--) { Tcl_Obj *objPtr; - objPtr = tosPtr[1 - objc + off]; + objPtr = tosPtr[1 - objc]; if (!objPtr) { Tcl_Panic("InnerContext: bad tos -- appending null object"); } @@ -860,10 +860,10 @@ static void PrintSourceToObj( Tcl_Obj *appendObj, /* The object to print the source to. */ const char *stringPtr, /* The string to print. */ - int maxChars) /* Maximum number of chars to print. */ + Tcl_Size maxChars) /* Maximum number of chars to print. */ { const char *p; - int i = 0, len; + Tcl_Size i = 0, len; if (stringPtr == NULL) { Tcl_AppendToObj(appendObj, "\"\"", -1); @@ -943,8 +943,8 @@ DisassembleByteCodeAsDicts( Tcl_Obj *description, *literals, *variables, *instructions, *inst; Tcl_Obj *aux, *exn, *commands, *file; unsigned char *pc, *opnd, *codeOffPtr, *codeLenPtr, *srcOffPtr, *srcLenPtr; - int codeOffset, codeLength, sourceOffset, sourceLength; - int i, val, line; + int codeOffset, codeLength, sourceOffset, sourceLength, val, line; + Tcl_Size i; ByteCodeGetInternalRep(objPtr, &tclByteCodeType, codePtr); @@ -963,7 +963,7 @@ DisassembleByteCodeAsDicts( TclNewObj(variables); if (codePtr->procPtr) { - int localCount = codePtr->procPtr->numCompiledLocals; + Tcl_Size localCount = codePtr->procPtr->numCompiledLocals; CompiledLocal *localPtr = codePtr->procPtr->firstLocalPtr; for (i=0 ; inextPtr) { @@ -1146,14 +1146,14 @@ DisassembleByteCodeAsDicts( switch (rangePtr->type) { case LOOP_EXCEPTION_RANGE: Tcl_ListObjAppendElement(NULL, exn, Tcl_ObjPrintf( - "type %s level %d from %d to %d break %d continue %d", + "type %s level %" TCL_SIZE_MODIFIER "u from %" TCL_SIZE_MODIFIER "u to %" TCL_SIZE_MODIFIER "u break %" TCL_SIZE_MODIFIER "u continue %" TCL_SIZE_MODIFIER "u", "loop", rangePtr->nestingLevel, rangePtr->codeOffset, rangePtr->codeOffset + rangePtr->numCodeBytes - 1, rangePtr->breakOffset, rangePtr->continueOffset)); break; case CATCH_EXCEPTION_RANGE: Tcl_ListObjAppendElement(NULL, exn, Tcl_ObjPrintf( - "type %s level %d from %d to %d catch %d", + "type %s level %" TCL_SIZE_MODIFIER "u from %" TCL_SIZE_MODIFIER "u to %" TCL_SIZE_MODIFIER "u catch %" TCL_SIZE_MODIFIER "u", "catch", rangePtr->nestingLevel, rangePtr->codeOffset, rangePtr->codeOffset + rangePtr->numCodeBytes - 1, rangePtr->catchOffset)); @@ -1528,7 +1528,7 @@ Tcl_DisassembleObjCmd( return TCL_ERROR; } hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods, - (char *) objv[3]); + (char *)objv[3]); goto methodBody; case DISAS_OBJECT_METHOD: if (objc != 4) { @@ -1547,7 +1547,7 @@ Tcl_DisassembleObjCmd( if (oPtr->methodsPtr == NULL) { goto unknownMethod; } - hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[3]); + hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *)objv[3]); /* * Compile (if necessary) and disassemble a method body. diff --git a/generic/tclInt.h b/generic/tclInt.h index 7114d66..25a23ed 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -877,6 +877,9 @@ typedef struct VarInHash { #define VarHashRefCount(varPtr) \ ((VarInHash *) (varPtr))->refCount +#define VarHashGetKey(varPtr) \ + (((VarInHash *)(varPtr))->entry.key.objPtr) + /* * Macros for direct variable access by TEBC. */ @@ -2676,7 +2679,7 @@ typedef struct ListRep { #define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \ ((((objPtr)->typePtr == &tclIntType) && ((objPtr)->internalRep.wideValue >= 0) \ && ((Tcl_WideUInt)(objPtr)->internalRep.wideValue <= (Tcl_WideUInt)(endValue + 1))) \ - ? ((*(idxPtr) = (int)(objPtr)->internalRep.wideValue), TCL_OK) \ + ? ((*(idxPtr) = (Tcl_Size)(objPtr)->internalRep.wideValue), TCL_OK) \ : Tcl_GetIntForIndex((interp), (objPtr), (endValue), (idxPtr))) /* @@ -4739,16 +4742,17 @@ MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[]; * of counting along a string of all one-byte characters. The ANSI C * "prototype" for this macro is: * - * MODULE_SCOPE void TclNumUtfCharsM(int numChars, const char *bytes, - * int numBytes); + * MODULE_SCOPE void TclNumUtfCharsM(Tcl_Size numChars, const char *bytes, + * Tcl_Size numBytes); + * numBytes must be >= 0 *---------------------------------------------------------------- */ #define TclNumUtfCharsM(numChars, bytes, numBytes) \ do { \ - int _count, _i = (numBytes); \ + Tcl_Size _count, _i = (numBytes); \ unsigned char *_str = (unsigned char *) (bytes); \ - while (_i && (*_str < 0xC0)) { _i--; _str++; } \ + while (_i > 0 && (*_str < 0xC0)) { _i--; _str++; } \ _count = (numBytes) - _i; \ if (_i) { \ _count += TclNumUtfChars((bytes) + _count, _i); \ @@ -4873,7 +4877,7 @@ MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; * * MODULE_SCOPE void TclNewIntObj(Tcl_Obj *objPtr, Tcl_WideInt w); * MODULE_SCOPE void TclNewDoubleObj(Tcl_Obj *objPtr, double d); - * MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, const char *s, int len); + * MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, const char *s, Tcl_Size len); * MODULE_SCOPE void TclNewLiteralStringObj(Tcl_Obj*objPtr, const char *sLiteral); * *---------------------------------------------------------------- diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index b97d16f..aea397e 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -53,7 +53,7 @@ static Tcl_ThreadDataKey dataKey; * with some information that is used to check the cached pointer's validity. */ -typedef struct ResolvedNsName { +typedef struct { Namespace *nsPtr; /* A cached pointer to the Namespace that the * name resolved to. */ Namespace *refNsPtr; /* Points to the namespace context in which @@ -326,7 +326,7 @@ Tcl_PushCallFrame( framePtr->callerPtr = iPtr->framePtr; framePtr->callerVarPtr = iPtr->varFramePtr; if (iPtr->varFramePtr != NULL) { - framePtr->level = (iPtr->varFramePtr->level + 1); + framePtr->level = iPtr->varFramePtr->level + 1U; } else { framePtr->level = 0; } @@ -409,9 +409,8 @@ Tcl_PopCallFrame( */ nsPtr = framePtr->nsPtr; - nsPtr->activationCount--; - if ((nsPtr->flags & NS_DYING) - && (nsPtr->activationCount - (nsPtr == iPtr->globalNsPtr) == 0)) { + if ((--nsPtr->activationCount <= (nsPtr == iPtr->globalNsPtr)) + && (nsPtr->flags & NS_DYING)) { Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr); } framePtr->nsPtr = NULL; @@ -671,7 +670,8 @@ Tcl_CreateNamespace( Tcl_HashEntry *entryPtr; Tcl_DString buffer1, buffer2; Tcl_DString *namePtr, *buffPtr; - int newEntry, nameLen; + int newEntry; + size_t nameLen; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); const char *nameStr; Tcl_DString tmpBuffer; @@ -1009,7 +1009,7 @@ Tcl_DeleteNamespace( * FreeNsNameInternalRep when its refCount reaches 0. */ - if (nsPtr->activationCount - (nsPtr == globalNsPtr) > 0) { + if (nsPtr->activationCount > (nsPtr == globalNsPtr)) { nsPtr->flags |= NS_DYING; if (nsPtr->parentPtr != NULL) { entryPtr = Tcl_FindHashEntry( @@ -1087,7 +1087,8 @@ TclDeleteNamespaceChildren( { Interp *iPtr = (Interp *) nsPtr->interp; Tcl_HashEntry *entryPtr; - int i, unchecked; + size_t i; + int unchecked; Tcl_HashSearch search; /* * Delete all the child namespaces. @@ -1105,7 +1106,7 @@ TclDeleteNamespaceChildren( #ifndef BREAK_NAMESPACE_COMPAT unchecked = (nsPtr->childTable.numEntries > 0); while (nsPtr->childTable.numEntries > 0 && unchecked) { - int length = nsPtr->childTable.numEntries; + size_t length = nsPtr->childTable.numEntries; Namespace **children = (Namespace **)TclStackAlloc((Tcl_Interp *) iPtr, sizeof(Namespace *) * length); @@ -1131,7 +1132,7 @@ TclDeleteNamespaceChildren( if (nsPtr->childTablePtr != NULL) { unchecked = (nsPtr->childTable.numEntries > 0); while (nsPtr->childTable.numEntries > 0 && unchecked) { - int length = nsPtr->childTablePtr->numEntries; + size_t length = nsPtr->childTablePtr->numEntries; Namespace **children = (Namespace **)TclStackAlloc((Tcl_Interp *) iPtr, sizeof(Namespace *) * length); @@ -1187,7 +1188,7 @@ TclTeardownNamespace( Interp *iPtr = (Interp *) nsPtr->interp; Tcl_HashEntry *entryPtr; Tcl_HashSearch search; - int i; + Tcl_Size i; /* * Start by destroying the namespace's variable table, since variables @@ -1208,7 +1209,7 @@ TclTeardownNamespace( */ while (nsPtr->cmdTable.numEntries > 0) { - int length = nsPtr->cmdTable.numEntries; + Tcl_Size length = nsPtr->cmdTable.numEntries; Command **cmds = (Command **)TclStackAlloc((Tcl_Interp *) iPtr, sizeof(Command *) * length); @@ -1398,7 +1399,7 @@ Tcl_Export( Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp); const char *simplePattern; char *patternCpy; - int neededElems, len, i; + Tcl_Size neededElems, len, i; /* * If the specified namespace is NULL, use the current namespace. @@ -1525,7 +1526,8 @@ Tcl_AppendExportList( * export pattern list is appended. */ { Namespace *nsPtr; - int i, result; + Tcl_Size i; + int result; /* * If the specified namespace is NULL, use the current namespace. @@ -1727,7 +1729,7 @@ DoImport( Namespace *importNsPtr, int allowOverwrite) { - int i = 0, exported = 0; + Tcl_Size i = 0, exported = 0; Tcl_HashEntry *found; /* @@ -2639,7 +2641,7 @@ Tcl_FindCommand( cmdPtr = NULL; if (cxtNsPtr->commandPathLength!=0 && strncmp(name, "::", 2) && !(flags & TCL_NAMESPACE_ONLY)) { - int i; + Tcl_Size i; Namespace *pathNsPtr, *realNsPtr, *dummyNsPtr; (void) TclGetNamespaceForQualName(interp, name, cxtNsPtr, @@ -3066,7 +3068,7 @@ NamespaceChildrenCmd( listPtr = Tcl_NewListObj(0, NULL); if ((pattern != NULL) && TclMatchIsTrivial(pattern)) { - unsigned int length = strlen(nsPtr->fullName); + size_t length = strlen(nsPtr->fullName); if (strncmp(pattern, nsPtr->fullName, length) != 0) { goto searchDone; @@ -3146,7 +3148,7 @@ NamespaceCodeCmd( Namespace *currNsPtr; Tcl_Obj *listPtr, *objPtr; const char *arg; - int length; + Tcl_Size length; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "arg"); @@ -3459,15 +3461,15 @@ NsEval_Callback( Tcl_Namespace *namespacePtr = (Tcl_Namespace *)data[0]; if (result == TCL_ERROR) { - int length = strlen(namespacePtr->fullName); - int limit = 200; + size_t length = strlen(namespacePtr->fullName); + unsigned limit = 200; int overflow = (length > limit); char *cmd = (char *)data[1]; Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (in namespace %s \"%.*s%s\" script line %d)", cmd, - (overflow ? limit : length), namespacePtr->fullName, + (overflow ? limit : (unsigned)length), namespacePtr->fullName, (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); } @@ -4040,7 +4042,8 @@ NamespacePathCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp); - int i, nsObjc, result = TCL_ERROR; + Tcl_Size nsObjc, i; + int result = TCL_ERROR; Tcl_Obj **nsObjv; Tcl_Namespace **namespaceList = NULL; @@ -4078,7 +4081,7 @@ NamespacePathCmd( namespaceList = (Tcl_Namespace **)TclStackAlloc(interp, sizeof(Tcl_Namespace *) * nsObjc); - for (i=0 ; icommandPathLength ; i++) { NamespacePathEntry *nsPathPtr = &nsPtr->commandPathArray[i]; @@ -4266,7 +4269,7 @@ NamespaceQualifiersCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { const char *name, *p; - int length; + size_t length; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "string"); @@ -4431,7 +4434,7 @@ Tcl_SetNamespaceUnknownHandler( Tcl_Namespace *nsPtr, /* Namespace which is being updated. */ Tcl_Obj *handlerPtr) /* The new handler, or NULL to reset. */ { - int lstlen = 0; + Tcl_Size lstlen = 0; Namespace *currNsPtr = (Namespace *) nsPtr; /* @@ -4903,11 +4906,11 @@ TclGetNamespaceChildTable( * * TclLogCommandInfo -- * - * This function is invoked after an error occurs in an interpreter. It - * adds information to iPtr->errorInfo/errorStack fields to describe the + * Invoked after an error occurs in an interpreter. + * Adds information to iPtr->errorInfo/errorStack fields to describe the * command that was being executed when the error occurred. When pc and * tosPtr are non-NULL, conveying a bytecode execution "inner context", - * and the offending instruction is suitable, that inner context is + * and the offending instruction is suitable, and that inner context is * recorded in errorStack. * * Results: @@ -4927,8 +4930,8 @@ TclLogCommandInfo( * command (must be <= command). */ const char *command, /* First character in command that generated * the error. */ - int length, /* Number of bytes in command (TCL_INDEX_NONE - * means use all bytes up to first null byte). + Tcl_Size length, /* Number of bytes in command (< 0 means use + * all bytes up to first null byte). */ const unsigned char *pc, /* Current pc of bytecode execution context */ Tcl_Obj **tosPtr) /* Current stack of bytecode execution @@ -4941,8 +4944,8 @@ TclLogCommandInfo( if (iPtr->flags & ERR_ALREADY_LOGGED) { /* - * Someone else has already logged error information for this command; - * we shouldn't add anything more. + * Someone else has already logged error information for this command. + * Don't add anything more. */ return; @@ -5013,7 +5016,7 @@ TclLogCommandInfo( iPtr->errorStack = newObj; } if (iPtr->resetErrorStack) { - int len; + Tcl_Size len; iPtr->resetErrorStack = 0; TclListObjLengthM(interp, iPtr->errorStack, &len); @@ -5085,7 +5088,7 @@ void TclErrorStackResetIf( Tcl_Interp *interp, const char *msg, - int length) + Tcl_Size length) { Interp *iPtr = (Interp *) interp; @@ -5098,7 +5101,7 @@ TclErrorStackResetIf( iPtr->errorStack = newObj; } if (iPtr->resetErrorStack) { - int len; + Tcl_Size len; iPtr->resetErrorStack = 0; TclListObjLengthM(interp, iPtr->errorStack, &len); @@ -5140,7 +5143,7 @@ Tcl_LogCommandInfo( * command (must be <= command). */ const char *command, /* First character in command that generated * the error. */ - int length) /* Number of bytes in command (-1 means use + Tcl_Size length) /* Number of bytes in command (-1 means use * all bytes up to first null byte). */ { TclLogCommandInfo(interp, script, command, length, NULL, NULL); diff --git a/generic/tclProc.c b/generic/tclProc.c index 3abf3c3..a107341 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -493,8 +493,8 @@ TclCreateProc( if (precompiled) { if (numArgs > procPtr->numArgs) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "procedure \"%s\": arg list contains %d entries, " - "precompiled header expects %d", procName, numArgs, + "procedure \"%s\": arg list contains %" TCL_SIZE_MODIFIER "u entries, " + "precompiled header expects %" TCL_SIZE_MODIFIER "u", procName, numArgs, procPtr->numArgs)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "BYTECODELIES", NULL); @@ -588,7 +588,7 @@ TclCreateProc( || (localPtr->defValuePtr == NULL && fieldCount == 2) || (localPtr->defValuePtr != NULL && fieldCount != 2)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "procedure \"%s\": formal parameter %d is " + "procedure \"%s\": formal parameter %" TCL_SIZE_MODIFIER "u is " "inconsistent with precompiled body", procName, i)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "BYTECODELIES", NULL); @@ -1065,7 +1065,7 @@ ProcWrongNumArgs( { CallFrame *framePtr = ((Interp *)interp)->varFramePtr; Proc *procPtr = framePtr->procPtr; - int localCt = procPtr->numCompiledLocals, numArgs, i; + Tcl_Size localCt = procPtr->numCompiledLocals, numArgs, i; Tcl_Obj **desiredObjs; const char *final = NULL; @@ -1400,7 +1400,7 @@ InitArgsAndLocals( Proc *procPtr = framePtr->procPtr; ByteCode *codePtr; Var *varPtr, *defPtr; - int localCt = procPtr->numCompiledLocals, numArgs, argCt, i, imax; + Tcl_Size localCt = procPtr->numCompiledLocals, numArgs, argCt, i, imax; Tcl_Obj *const *argObjs; ByteCodeGetInternalRep(procPtr->bodyPtr, &tclByteCodeType, codePtr); @@ -1559,7 +1559,7 @@ TclPushProcCallFrame( * interpreted. */ Tcl_Interp *interp,/* Interpreter in which procedure was * invoked. */ - Tcl_Size objc, /* Count of number of arguments to this + Tcl_Size objc, /* Count of number of arguments to this * procedure. */ Tcl_Obj *const objv[], /* Argument value objects. */ int isLambda) /* 1 if this is a call by ApplyObjCmd: it @@ -1686,9 +1686,9 @@ TclNRInterpProc( static int NRInterpProc2( - void *clientData, /* Record describing procedure to be + void *clientData, /* Record describing procedure to be * interpreted. */ - Tcl_Interp *interp,/* Interpreter in which procedure was + Tcl_Interp *interp, /* Interpreter in which procedure was * invoked. */ ptrdiff_t objc, /* Count of number of arguments to this * procedure. */ @@ -1705,9 +1705,9 @@ NRInterpProc2( static int ObjInterpProc2( - void *clientData, /* Record describing procedure to be + void *clientData, /* Record describing procedure to be * interpreted. */ - Tcl_Interp *interp,/* Interpreter in which procedure was + Tcl_Interp *interp, /* Interpreter in which procedure was * invoked. */ ptrdiff_t objc, /* Count of number of arguments to this * procedure. */ @@ -2021,7 +2021,7 @@ TclProcCompileProc( TclNewLiteralStringObj(message, "Compiling "); Tcl_IncrRefCount(message); Tcl_AppendStringsToObj(message, description, " \"", NULL); - Tcl_AppendLimitedToObj(message, procName, -1, 50, NULL); + Tcl_AppendLimitedToObj(message, procName, TCL_INDEX_NONE, 50, NULL); fprintf(stdout, "%s\"\n", TclGetString(message)); Tcl_DecrRefCount(message); } diff --git a/generic/tclVar.c b/generic/tclVar.c index ea8a104..70ba63b 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -108,9 +108,6 @@ VarHashNextVar( return VarHashGetValue(hPtr); } -#define VarHashGetKey(varPtr) \ - (((VarInHash *)(varPtr))->entry.key.objPtr) - #define VarHashDeleteTable(tablePtr) \ Tcl_DeleteHashTable(&(tablePtr)->table) @@ -844,8 +841,8 @@ TclLookupSimpleVar( * the variable. */ Namespace *varNsPtr, *cxtNsPtr, *dummy1Ptr, *dummy2Ptr; ResolverScheme *resPtr; - int isNew, i, result; - Tcl_Size varLen; + int isNew, result; + Tcl_Size i, varLen; const char *varName = TclGetStringFromObj(varNamePtr, &varLen); varPtr = NULL; @@ -974,7 +971,7 @@ TclLookupSimpleVar( } } } else { /* Local var: look in frame varFramePtr. */ - int localCt = varFramePtr->numCompiledLocals; + Tcl_Size localCt = varFramePtr->numCompiledLocals; if (localCt > 0) { Tcl_Obj **objPtrPtr = &varFramePtr->localCachePtr->varName0; -- cgit v0.12 From 09c0f6835523794621c9bae88e5ea3b955c14878 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 21 Jun 2023 07:13:48 +0000 Subject: "trace variable" -> "trace add variable" in testcases (and documentation) --- doc/trace.n | 2 +- doc/upvar.n | 2 +- tests/append.test | 16 +++++++-------- tests/appendComp.test | 30 ++++++++++++++-------------- tests/expr.test | 2 +- tests/if.test | 2 +- tests/incr-old.test | 2 +- tests/init.test | 2 +- tests/link.test | 10 +++++----- tests/namespace-old.test | 4 ++-- tests/proc-old.test | 16 +++++++-------- tests/set-old.test | 16 +++++++-------- tests/set.test | 4 ++-- tests/trace.test | 52 ++++++++++++++++++++++++------------------------ tests/upvar.test | 14 ++++++------- tests/var.test | 24 +++++++++++----------- 16 files changed, 99 insertions(+), 99 deletions(-) diff --git a/doc/trace.n b/doc/trace.n index 570b263..9b8fd57 100644 --- a/doc/trace.n +++ b/doc/trace.n @@ -238,7 +238,7 @@ if an entire array is being deleted and the trace was registered on the overall array, rather than a single element, then \fIname1\fR gives the array name and \fIname2\fR is an empty string. \fIName1\fR and \fIname2\fR are not necessarily the same as the -name used in the \fBtrace variable\fR command: the \fBupvar\fR +name used in the \fBtrace add variable\fR command: the \fBupvar\fR command allows a procedure to reference a variable under a different name. \fIOp\fR indicates what operation is being performed on the diff --git a/doc/upvar.n b/doc/upvar.n index 91defe6..5d697dd 100644 --- a/doc/upvar.n +++ b/doc/upvar.n @@ -94,7 +94,7 @@ proc \fIsetByUpvar\fR { name value } { set localVar $value } set originalVar 1 -trace variable originalVar w \fItraceproc\fR +trace add variable originalVar write \fItraceproc\fR \fIsetByUpvar\fR originalVar 2 .CE .PP diff --git a/tests/append.test b/tests/append.test index c0c0cce..1055ae0 100644 --- a/tests/append.test +++ b/tests/append.test @@ -221,7 +221,7 @@ test append-7.1 {lappend-created var and error in trace on that var} -setup { catch {rename foo ""} unset -nocomplain x } -body { - trace variable x w foo + trace add variable x write foo proc foo {} {global x; unset x} catch {lappend x 1} proc foo {args} {global x; unset x} @@ -234,37 +234,37 @@ test append-7.2 {lappend var triggers read trace} -setup { unset -nocomplain myvar unset -nocomplain ::result } -body { - trace variable myvar r foo + trace add variable myvar read foo proc foo {args} {append ::result $args} lappend myvar a return $::result -} -result {myvar {} r} +} -result {myvar {} read} test append-7.3 {lappend var triggers read trace, array var} -setup { unset -nocomplain myvar unset -nocomplain ::result } -body { # The behavior of read triggers on lappend changed in 8.0 to not trigger # them, and was changed back in 8.4. - trace variable myvar r foo + trace add variable myvar read foo proc foo {args} {append ::result $args} lappend myvar(b) a return $::result -} -result {myvar b r} +} -result {myvar b read} test append-7.4 {lappend var triggers read trace, array var exists} -setup { unset -nocomplain myvar unset -nocomplain ::result } -body { set myvar(0) 1 - trace variable myvar r foo + trace add variable myvar read foo proc foo {args} {append ::result $args} lappend myvar(b) a return $::result -} -result {myvar b r} +} -result {myvar b read} test append-7.5 {append var does not trigger read trace} -setup { unset -nocomplain myvar unset -nocomplain ::result } -body { - trace variable myvar r foo + trace add variable myvar read foo proc foo {args} {append ::result $args} append myvar a info exists ::result diff --git a/tests/appendComp.test b/tests/appendComp.test index 121b704..ddb4fb2 100644 --- a/tests/appendComp.test +++ b/tests/appendComp.test @@ -250,7 +250,7 @@ test appendComp-7.1 {lappendComp-created var and error in trace on that var} -se } -body { proc bar {} { global x - trace variable x w foo + trace add variable x write foo proc foo {} {global x; unset x} catch {lappend x 1} proc foo {args} {global x; unset x} @@ -265,19 +265,19 @@ test appendComp-7.2 {lappend var triggers read trace, index var} -setup { unset -nocomplain ::result } -body { proc bar {} { - trace variable myvar r foo + trace add variable myvar read foo proc foo {args} {append ::result $args} lappend myvar a return $::result } bar -} -result {myvar {} r} -constraints {bug-3057639} +} -result {myvar {} read} -constraints {bug-3057639} test appendComp-7.3 {lappend var triggers read trace, stack var} -setup { unset -nocomplain ::result unset -nocomplain ::myvar } -body { proc bar {} { - trace variable ::myvar r foo + trace add variable ::myvar read foo proc foo {args} {append ::result $args} lappend ::myvar a return $::result @@ -290,67 +290,67 @@ test appendComp-7.4 {lappend var triggers read trace, array var} -setup { # The behavior of read triggers on lappend changed in 8.0 to not trigger # them. Maybe not correct, but been there a while. proc bar {} { - trace variable myvar r foo + trace add variable myvar read foo proc foo {args} {append ::result $args} lappend myvar(b) a return $::result } bar -} -result {myvar b r} -constraints {bug-3057639} +} -result {myvar b read} -constraints {bug-3057639} test appendComp-7.5 {lappend var triggers read trace, array var} -setup { unset -nocomplain ::result } -body { # The behavior of read triggers on lappend changed in 8.0 to not trigger # them. Maybe not correct, but been there a while. proc bar {} { - trace variable myvar r foo + trace add variable myvar read foo proc foo {args} {append ::result $args} lappend myvar(b) a b return $::result } bar -} -result {myvar b r} +} -result {myvar b read} test appendComp-7.6 {lappend var triggers read trace, array var exists} -setup { unset -nocomplain ::result } -body { proc bar {} { set myvar(0) 1 - trace variable myvar r foo + trace add variable myvar read foo proc foo {args} {append ::result $args} lappend myvar(b) a return $::result } bar -} -result {myvar b r} -constraints {bug-3057639} +} -result {myvar b read} -constraints {bug-3057639} test appendComp-7.7 {lappend var triggers read trace, array stack var} -setup { unset -nocomplain ::myvar unset -nocomplain ::result } -body { proc bar {} { - trace variable ::myvar r foo + trace add variable ::myvar read foo proc foo {args} {append ::result $args} lappend ::myvar(b) a return $::result } bar -} -result {::myvar b r} -constraints {bug-3057639} +} -result {::myvar b read} -constraints {bug-3057639} test appendComp-7.8 {lappend var triggers read trace, array stack var} -setup { unset -nocomplain ::myvar unset -nocomplain ::result } -body { proc bar {} { - trace variable ::myvar r foo + trace add variable ::myvar read foo proc foo {args} {append ::result $args} lappend ::myvar(b) a b return $::result } bar -} -result {::myvar b r} +} -result {::myvar b read} test appendComp-7.9 {append var does not trigger read trace} -setup { unset -nocomplain ::result } -body { proc bar {} { - trace variable myvar r foo + trace add variable myvar read foo proc foo {args} {append ::result $args} append myvar a info exists ::result diff --git a/tests/expr.test b/tests/expr.test index 985bce1..b0790e6a 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -779,7 +779,7 @@ test expr-20.2 {double invocation of variable traces} -body { set var "$counter + [concat $extraargs]" } } - trace variable exprtracevar r [list exprtraceproc 10] + trace add variable exprtracevar read [list exprtraceproc 10] list [catch {expr "$exprtracevar + 20"} a] $a \ [catch {expr "$exprtracevar + 20"} b] $b \ [unset exprtracevar exprtracecounter] diff --git a/tests/if.test b/tests/if.test index c5babdd..a1399a0 100644 --- a/tests/if.test +++ b/tests/if.test @@ -1265,7 +1265,7 @@ test if-10.6 {double invocation of variable traces} -body { set var "$counter + [concat $extraargs]" } } - trace variable iftracevar r [list iftraceproc 10] + trace add variable iftracevar read [list iftraceproc 10] list [catch {if "$iftracevar + 20" {}} a] $a \ [catch {if "$iftracevar + 20" {}} b] $b } -cleanup { diff --git a/tests/incr-old.test b/tests/incr-old.test index 818bccc..662fdc7 100644 --- a/tests/incr-old.test +++ b/tests/incr-old.test @@ -63,7 +63,7 @@ test incr-old-2.5 {incr errors} { test incr-old-2.6 {incr errors} -body { proc readonly args {error "variable is read-only"} set x 123 - trace var x w readonly + trace add var x write readonly list [catch {incr x 1} msg] $msg $::errorInfo } -match glob -result {1 {can't set "x": variable is read-only} {*variable is read-only while executing diff --git a/tests/init.test b/tests/init.test index 4acad3d..ac80016 100644 --- a/tests/init.test +++ b/tests/init.test @@ -170,7 +170,7 @@ foreach arg [subst -nocommands -novariables { auto_reset } -body { namespace eval junk [list array set $arg [list 1 2 3 4]] - trace variable ::junk::$arg r \ + trace add variable ::junk::$arg read \ "[list error [subst {Variable \"$arg\" is write-only}]] ;# " catch {parray ::junk::$arg} set first $::errorInfo diff --git a/tests/link.test b/tests/link.test index 43a85fb..6ac2277 100644 --- a/tests/link.test +++ b/tests/link.test @@ -384,11 +384,11 @@ test link-8.1 {Tcl_UpdateLinkedVar procedure} {testlink} { set x {} testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 testlink set 14 -2.0 0 xyzzy 995511 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234 - trace var int w x + trace add var int write x testlink update 32 4.0 3 abcd 113355 65 251 30001 60001 0xbabebeef 12322 32124 3.125 12312312340 - trace vdelete int w x + trace remove var int write x return $x -} {{int {} w} 32 -2.0 0 xyzzy 995511} +} {{int {} write} 32 -2.0 0 xyzzy 995511} test link-8.2 {Tcl_UpdateLinkedVar procedure} {testlink} { proc x args { global x int real bool string wide @@ -398,9 +398,9 @@ test link-8.2 {Tcl_UpdateLinkedVar procedure} {testlink} { testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 testlink set 14 -2.0 0 xyzzy 995511 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234 testlink delete - trace var int w x + trace add var int write x testlink update 32 4.0 6 abcd 113355 65 251 30001 60001 0xbabebeef 12322 32124 3.125 12312312340 - trace vdelete int w x + trace remove var int write x return $x } {} test link-8.3 {Tcl_UpdateLinkedVar procedure, read-only variable} {testlink} { diff --git a/tests/namespace-old.test b/tests/namespace-old.test index 06eedfd..468c648 100644 --- a/tests/namespace-old.test +++ b/tests/namespace-old.test @@ -631,13 +631,13 @@ test namespace-old-8.1 {traces work across namespace boundaries} { variable status lappend status "$op: $name1" } - trace variable foo::x rwu [namespace code monitor] + trace add variable foo::x {read write unset} [namespace code monitor] } set test_ns_trace::foo::x "yes!" set test_ns_trace::foo::x unset test_ns_trace::foo::x namespace eval test_ns_trace { set status } -} {{w: test_ns_trace::foo::x} {r: test_ns_trace::foo::x} {u: test_ns_trace::foo::x}} +} {{write: test_ns_trace::foo::x} {read: test_ns_trace::foo::x} {unset: test_ns_trace::foo::x}} # ----------------------------------------------------------------------- # TEST: imported commands diff --git a/tests/proc-old.test b/tests/proc-old.test index ab93fca..2f0f417 100644 --- a/tests/proc-old.test +++ b/tests/proc-old.test @@ -137,25 +137,25 @@ test proc-old-3.7 {local and global arrays} { proc t1 {args} {global info; set info 1} catch {unset a} set info {} - do {global a; trace var a(1) w t1} + do {global a; trace add var a(1) write t1} set a(1) 44 set info } 1 test proc-old-3.8 {local and global arrays} { proc t1 {args} {global info; set info 1} catch {unset a} - trace var a(1) w t1 + trace add var a(1) write t1 set info {} - do {global a; trace vdelete a(1) w t1} + do {global a; trace remove var a(1) write t1} set a(1) 44 set info } {} test proc-old-3.9 {local and global arrays} { proc t1 {args} {global info; set info 1} catch {unset a} - trace var a(1) w t1 - do {global a; trace vinfo a(1)} -} {{w t1}} + trace add var a(1) write t1 + do {global a; trace info var a(1)} +} {{write t1}} catch {unset a} test proc-old-30.1 {arguments and defaults} { @@ -349,7 +349,7 @@ test proc-old-5.16 {error conditions} { } proc tproc {} { set x 44 - trace var x u foo + trace add var x unset foo while {$x < 100} { error "Nested error" } @@ -361,7 +361,7 @@ test proc-old-5.16 {error conditions} { "error "Nested error"" (procedure "tproc" line 5) invoked from within -"tproc"} {foo was called: x {} u}} +"tproc"} {foo was called: x {} unset}} # The tests below will really only be useful when run under Purify or # some other system that can detect accesses to freed memory... diff --git a/tests/set-old.test b/tests/set-old.test index 052bd23..3289ae8 100644 --- a/tests/set-old.test +++ b/tests/set-old.test @@ -169,7 +169,7 @@ test set-old-5.4 {errors in reading variables} { test set-old-6.1 {creating array during write} { catch {unset a} - trace var a rwu ignore + trace add var a {read write unset} ignore list [catch {set a(14) 186} msg] $msg [array names a] } {0 186 14} test set-old-6.2 {errors in writing variables} { @@ -407,7 +407,7 @@ test set-old-8.18 {array command, get option} { test set-old-8.19 {array command, get option (unset variable)} { catch {unset a} set a(x) 3 - trace var a(y) w ignore + trace add var a(y) write ignore array get a } {x 3} test set-old-8.20 {array command, get option, with pattern} { @@ -445,13 +445,13 @@ test set-old-8.24 {array command, names option} { test set-old-8.25 {array command, names option} { catch {unset a} set a(22) 3; set a(33) 44; - trace var a(xxx) w ignore + trace add var a(xxx) write ignore list [catch {lsort [array names a]} msg] $msg } {0 {22 33}} test set-old-8.26 {array command, names option} { catch {unset a} set a(22) 3; set a(33) 44; - trace var a(xxx) w ignore + trace add var a(xxx) write ignore set a(xxx) value list [catch {lsort [array names a]} msg] $msg } {0 {22 33 xxx}} @@ -579,7 +579,7 @@ test set-old-8.43 {array command, size option} { test set-old-8.44 {array command, size option} { catch {unset a} set a(22) 3; - trace var a(33) rwu ignore + trace add var a(33) {read write unset} ignore list [catch {array size a} msg] $msg } {0 1} test set-old-8.45 {array command, size option, array doesn't exist yet but has compiler-allocated procedure slot} { @@ -786,7 +786,7 @@ test set-old-9.10 {array enumeration: searches automatically stopped} { set a(a) 1 set x [array startsearch a] set y [array startsearch a] - trace var a(b) r {} + trace add var a(b) read {} list [catch {array next a $x} msg] $msg \ [catch {array next a $y} msg2] $msg2 } {1 {couldn't find search "s-1-a"} 1 {couldn't find search "s-2-a"}} @@ -795,14 +795,14 @@ test set-old-9.11 {array enumeration: searches automatically stopped} { set a(a) 1 set x [array startsearch a] set y [array startsearch a] - trace var a(a) r {} + trace add var a(a) read {} list [catch {array next a $x} msg] $msg \ [catch {array next a $y} msg2] $msg2 } {0 a 0 a} test set-old-9.12 {array enumeration with traced undefined elements} { catch {unset a} set a(a) 1 - trace var a(b) r {} + trace add var a(b) read {} set x [array startsearch a] lsort [list [array next a $x] [array next a $x]] } {{} a} diff --git a/tests/set.test b/tests/set.test index 357e34b..3f099a3 100644 --- a/tests/set.test +++ b/tests/set.test @@ -263,7 +263,7 @@ test set-2.4 {set command: runtime error, readonly variable} -setup { } -body { proc readonly args {error "variable is read-only"} set x 123 - trace var x w readonly + trace add var x write readonly list [catch {set x 1} msg] $msg $::errorInfo } -match glob -result {1 {can't set "x": variable is read-only} {*variable is read-only while executing @@ -521,7 +521,7 @@ test set-4.4 {uncompiled set command: runtime error, readonly variable} -body { set z set proc readonly args {error "variable is read-only"} $z x 123 - trace var x w readonly + trace add var x write readonly list [catch {$z x 1} msg] $msg $::errorInfo } -match glob -result {1 {can't set "x": variable is read-only} {*variable is read-only while executing diff --git a/tests/trace.test b/tests/trace.test index 3f30048..d3c2dad 100644 --- a/tests/trace.test +++ b/tests/trace.test @@ -76,26 +76,26 @@ test trace-0.0 {memory corruption in trace (Tcl Bug 484339)} { trace add variable z array {set z(foo) 1 ;#} set res "names: [array names z]" unset -nocomplain ::z - trace variable ::z w {unset ::z; error "memory corruption";#} + trace add variable ::z write {unset ::z; error "memory corruption";#} list [catch {set ::z 1} msg] $msg } {1 {can't set "::z": memory corruption}} # Read-tracing on variables -test trace-1.1 {trace variable reads} { +test trace-1.1 {trace add variable reads} { 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} { +test trace-1.2 {trace add variable reads} { 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} { +test trace-1.3 {trace add variable reads} { unset -nocomplain x set info {} trace add variable x read traceScalar @@ -156,7 +156,7 @@ test trace-1.9 {trace reads on whole arrays} { 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} { +test trace-1.10 {trace add variable reads} { unset -nocomplain x set x 444 set info {} @@ -167,35 +167,35 @@ test trace-1.10 {trace variable reads} { test trace-1.11 {read traces that modify the array structure} { unset -nocomplain x set x(bar) 0 - trace variable x r {set x(foo) 1 ;#} - trace variable x r {unset -nocomplain x(bar) ;#} + trace add variable x read {set x(foo) 1 ;#} + trace add variable x read {unset -nocomplain x(bar) ;#} array get x } {} test trace-1.12 {read traces that modify the array structure} { unset -nocomplain x set x(bar) 0 - trace variable x r {unset -nocomplain x(bar) ;#} - trace variable x r {set x(foo) 1 ;#} + trace add variable x read {unset -nocomplain x(bar) ;#} + trace add variable x read {set x(foo) 1 ;#} array get x } {} test trace-1.13 {read traces that modify the array structure} { unset -nocomplain x set x(bar) 0 - trace variable x r {set x(foo) 1 ;#} - trace variable x r {unset -nocomplain x;#} + trace add variable x read {set x(foo) 1 ;#} + trace add variable x read {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} { unset -nocomplain x set x(bar) 0 - trace variable x r {unset -nocomplain x;#} - trace variable x r {set x(foo) 1 ;#} + trace add variable x read {unset -nocomplain x;#} + trace add variable x read {set x(foo) 1 ;#} list [catch {array get x} res] $res } {1 {can't read "x(bar)": no such variable}} # Basic write-tracing on variables -test trace-2.1 {trace variable writes} { +test trace-2.1 {trace add variable writes} { unset -nocomplain x set info {} trace add variable x write traceScalar @@ -216,7 +216,7 @@ test trace-2.3 {trace writes on whole arrays} { set x(abc) qq set info } {x abc write 0 qq} -test trace-2.4 {trace variable writes} { +test trace-2.4 {trace add variable writes} { unset -nocomplain x set x 1234 set info {} @@ -224,7 +224,7 @@ test trace-2.4 {trace variable writes} { set x set info } {} -test trace-2.5 {trace variable writes} { +test trace-2.5 {trace add variable writes} { unset -nocomplain x set x 1234 set info {} @@ -232,7 +232,7 @@ test trace-2.5 {trace variable writes} { unset x set info } {} -test trace-2.6 {trace variable writes on compiled local} { +test trace-2.6 {trace add variable writes on compiled local} { # # Check correct function of whole array traces on compiled local # arrays [Bug 1770591]. The corresponding function for read traces is @@ -247,7 +247,7 @@ test trace-2.6 {trace variable writes on compiled local} { p set info } {x X write 0 willy} -test trace-2.7 {trace variable writes on errorInfo} -body { +test trace-2.7 {trace add variable writes on errorInfo} -body { # # Check correct behaviour of write traces on errorInfo. # [Bug 1773040] @@ -266,7 +266,7 @@ test trace-2.7 {trace variable writes on errorInfo} -body { # still trigger these read traces. Also lappend triggers only one write # trace: after appending all arguments to the list. -test trace-3.1 {trace variable read-modify-writes} { +test trace-3.1 {trace add variable read-modify-writes} { unset -nocomplain x set info {} trace add variable x read traceScalarAppend @@ -275,7 +275,7 @@ test trace-3.1 {trace variable read-modify-writes} { lappend x 789 set info } {x {} read 0 123456} -test trace-3.2 {trace variable read-modify-writes} { +test trace-3.2 {trace add variable read-modify-writes} { unset -nocomplain x set info {} trace add variable x {read write} traceScalarAppend @@ -286,7 +286,7 @@ test trace-3.2 {trace variable read-modify-writes} { # Basic unset-tracing on variables -test trace-4.1 {trace variable unsets} { +test trace-4.1 {trace add variable unsets} { unset -nocomplain x set info {} trace add variable x unset traceScalar @@ -397,10 +397,10 @@ test trace-5.4 {array traces properly listed in trace information} { } [list [list array traceArray2]] test trace-5.5 {array traces properly listed in trace information} { unset -nocomplain x - trace variable x a traceArray2 - set result [trace vinfo x] + trace add variable x array traceArray2 + set result [trace info variable x] set result -} [list [list a traceArray2]] +} [list [list array traceArray2]] test trace-5.6 {array traces don't fire on scalar variables} { unset -nocomplain x set x foo @@ -1241,7 +1241,7 @@ test trace-18.2 {namespace delete / trace vdelete combo} { proc p1 args { trace vdelete ::foo::x u p1 } - trace variable ::foo::x u p1 + trace add variable ::foo::x unset p1 namespace delete ::foo info exists ::foo::x } 0 @@ -2420,7 +2420,7 @@ test trace-32.1 { test trace-33.1 {variable match with remove variable} { unset -nocomplain x - trace variable x w foo + trace add variable x write foo trace remove variable x write foo llength [trace info variable x] } 0 diff --git a/tests/upvar.test b/tests/upvar.test index c31eaa1..8a1319e 100644 --- a/tests/upvar.test +++ b/tests/upvar.test @@ -187,26 +187,26 @@ test upvar-4.2 {nested upvars} { proc tproc {args} {global x; set x [list $args [uplevel info vars]]} test upvar-5.1 {traces involving upvars} { - proc p1 {a b} {set c 22; set d 33; trace var c rw tproc; p2} + proc p1 {a b} {set c 22; set d 33; trace add var c {read write} tproc; p2} proc p2 {} {upvar c x1; set x1 22} set x --- p1 foo bar set x -} {{x1 {} w} x1} +} {{x1 {} write} x1} test upvar-5.2 {traces involving upvars} { - proc p1 {a b} {set c 22; set d 33; trace var c rw tproc; p2} + proc p1 {a b} {set c 22; set d 33; trace add var c {read write} tproc; p2} proc p2 {} {upvar c x1; set x1} set x --- p1 foo bar set x -} {{x1 {} r} x1} +} {{x1 {} read} x1} test upvar-5.3 {traces involving upvars} { - proc p1 {a b} {set c 22; set d 33; trace var c rwu tproc; p2} + proc p1 {a b} {set c 22; set d 33; trace add var c {read write unset} tproc; p2} proc p2 {} {upvar c x1; unset x1} set x --- p1 foo bar set x -} {{x1 {} u} x1} +} {{x1 {} unset} x1} test upvar-6.1 {retargeting an upvar} { proc p1 {} { @@ -355,7 +355,7 @@ test upvar-8.6 {errors in upvar command} -returnCodes error -body { p1 } -result {variable "a" already exists} test upvar-8.7 {errors in upvar command} -returnCodes error -body { - proc p1 {} {trace variable a w foo; upvar b a} + proc p1 {} {trace add variable a write foo; upvar b a} p1 } -result {variable "a" has traces: can't use for upvar} test upvar-8.8 {create nested array with upvar} -body { diff --git a/tests/var.test b/tests/var.test index 15edf6e..5300adc 100644 --- a/tests/var.test +++ b/tests/var.test @@ -597,10 +597,10 @@ test var-8.1 {TclDeleteVars, "unset" traces are called with fully-qualified var variable info set info [concat $info [list $name1 $name2 $op]] } - trace var v u [namespace code traceUnset] + trace add var v unset [namespace code traceUnset] } list [unset test_ns_var::v] $test_ns_var::info -} -result {{} {test_ns_var::v {} u}} +} -result {{} {test_ns_var::v {} unset}} test var-8.2 {TclDeleteNamespaceVars, "unset" traces on ns delete are called with fully-qualified var names} -setup { catch {namespace delete test_ns_var} catch {unset a} @@ -608,13 +608,13 @@ test var-8.2 {TclDeleteNamespaceVars, "unset" traces on ns delete are called wit set info "" namespace eval test_ns_var { variable v 123 1 - trace var v u ::traceUnset + trace add var v unset ::traceUnset } proc traceUnset {name1 name2 op} { set ::info [concat $::info [list $name1 $name2 $op]] } list [namespace delete test_ns_var] $::info -} -result {{} {::test_ns_var::v {} u}} +} -result {{} {::test_ns_var::v {} unset}} test var-8.3 {TclDeleteNamespaceVars, mem leak} -constraints memory -setup { proc ::t {a i o} { @@ -624,7 +624,7 @@ test var-8.3 {TclDeleteNamespaceVars, mem leak} -constraints memory -setup { leaktest { namespace eval n { variable v 123 - trace variable v u ::t + trace add variable v unset ::t } namespace delete n } @@ -703,8 +703,8 @@ test var-9.9 {behaviour of TclGetVar read trace success} -setup { } -constraints testsetnoerr -body { proc resetvar {val name elem op} {upvar 1 $name v; set v $val} set u 10 - trace var u r [list resetvar 1] - trace var v r [list resetvar 2] + trace add var u read [list resetvar 1] + trace add var v read [list resetvar 2] list \ [testsetnoerr u] \ [testseterr v] @@ -712,7 +712,7 @@ test var-9.9 {behaviour of TclGetVar read trace success} -setup { test var-9.10 {behaviour of TclGetVar read trace error} testsetnoerr { proc writeonly args {error "write-only"} set v 456 - trace var v r writeonly + trace add var v read writeonly list \ [catch {testsetnoerr v} msg] $msg \ [catch {testseterr v} msg] $msg @@ -723,8 +723,8 @@ test var-9.11 {behaviour of TclSetVar write trace success} -setup { } -constraints testsetnoerr -body { proc doubleval {name elem op} {upvar 1 $name v; set v [expr {2 * $v}]} set v 1 - trace var v w doubleval - trace var u w doubleval + trace add var v write doubleval + trace add var u write doubleval list \ [testsetnoerr u 2] \ [testseterr v 3] @@ -732,7 +732,7 @@ test var-9.11 {behaviour of TclSetVar write trace success} -setup { test var-9.12 {behaviour of TclSetVar write trace error} testsetnoerr { proc readonly args {error "read-only"} set v 456 - trace var v w readonly + trace add var v write readonly list \ [catch {testsetnoerr v 2} msg] $msg $v \ [catch {testseterr v 3} msg] $msg $v @@ -794,7 +794,7 @@ test var-13.1 {Tcl_UnsetVar2, unset array with trace set on element} -setup { } namespace eval :: { set t(1) 1 - trace variable t(1) u foo + trace add variable t(1) unset foo unset t } set x "If you see this, it worked" -- cgit v0.12