From 83ae4550f1932eba49b33dcf1e661e6559d17248 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 9 Jul 2014 18:49:38 +0000 Subject: Don't use Tcl_GetCommandInfo when Tcl_FindCommand suffices. --- generic/tclZlib.c | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 2e27303..4ccda3b 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -643,7 +643,6 @@ Tcl_ZlibStreamInit( int e; ZlibStreamHandle *zshPtr = NULL; Tcl_DString cmdname; - Tcl_CmdInfo cmdinfo; GzipHeader *gzHeaderPtr = NULL; switch (mode) { @@ -769,8 +768,8 @@ Tcl_ZlibStreamInit( Tcl_DStringInit(&cmdname); TclDStringAppendLiteral(&cmdname, "::tcl::zlib::streamcmd_"); TclDStringAppendObj(&cmdname, Tcl_GetObjResult(interp)); - if (Tcl_GetCommandInfo(interp, Tcl_DStringValue(&cmdname), - &cmdinfo) == 1) { + if (Tcl_FindCommand(interp, Tcl_DStringValue(&cmdname), + NULL, 0) != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "BUG: Stream command name already exists", -1)); Tcl_SetErrorCode(interp, "TCL", "BUG", "EXISTING_CMD", NULL); -- cgit v0.12 From 2ebc99f24c5036009ba72a25e29a6daf38f6e225 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 10 Jul 2014 12:52:10 +0000 Subject: Repair buffer indexing error in Tcl_ReadRaw() exposed by iogt-6.0 and valgrind. --- generic/tclIO.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 9deec87..1a9ff65 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -5023,7 +5023,7 @@ Tcl_ReadRaw( if (bytesToRead > 0) { - int nread = ChanRead(chanPtr, readBuf+copied, bytesToRead); + int nread = ChanRead(chanPtr, readBuf, bytesToRead); if (nread > 0) { /* Successful read (short is OK) - add to bytes copied */ -- cgit v0.12 From 5c5fdd7d09e5473a987675963b90be7066a72247 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 10 Jul 2014 15:45:32 +0000 Subject: [7368d225a6] Extend the auto-cleanup of zero ref count values passed in to the Tcl_*SetVar*() family of routines to cover the missing case where the flags value of TCL_APPEND_VALUE is passed in alone. *** POTENTIAL INCOMAPTIBILITY*** --- generic/tclVar.c | 3 +++ 1 file changed, 3 insertions(+) diff --git a/generic/tclVar.c b/generic/tclVar.c index 12d6911..fda5ff5 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -1916,6 +1916,9 @@ TclPtrSetVar( Tcl_IncrRefCount(oldValuePtr); /* Since var is ref */ } Tcl_AppendObjToObj(oldValuePtr, newValuePtr); + if (newValuePtr->refCount == 0) { + Tcl_DecrRefCount(newValuePtr); + } } } } else if (newValuePtr != oldValuePtr) { -- cgit v0.12 From b7bbd160ec1577a4212fc261c1de5489dff65596 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 10 Jul 2014 17:21:23 +0000 Subject: [f652ae79ed] Close sockets used in tests, so as not to corrupt other tests in the suite. --- tests/socket.test | 1 + 1 file changed, 1 insertion(+) diff --git a/tests/socket.test b/tests/socket.test index 2bd2731..93fdb2d 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -2309,6 +2309,7 @@ test socket-14.15 {blocking read on async socket should not trigger event handle set x ok fileevent $s writable {set x fail} catch {read $s} + close $s set x } -result ok -- cgit v0.12 From 8f7dce1bcda533fc3f4cc6aecee46e7ab6a4a7b3 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 10 Jul 2014 18:00:42 +0000 Subject: dup test name --- tests/io.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/io.test b/tests/io.test index c1938a1..925f8c6 100644 --- a/tests/io.test +++ b/tests/io.test @@ -4052,7 +4052,7 @@ test io-32.11.1 {Tcl_Read from a pipe} {stdio openpipe} { } {{hello } {hello }} -test io-32.11.1 {Tcl_Read from a pipe} {stdio openpipe} { +test io-32.11.2 {Tcl_Read from a pipe} {stdio openpipe} { file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 {chan configure stdout -translation crlf} -- cgit v0.12 From 727acbea9d3864df74090ab1146fdbec3e64c225 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 10 Jul 2014 18:11:39 +0000 Subject: makeFile / removeFile balance --- tests/socket.test | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/tests/socket.test b/tests/socket.test index 93fdb2d..c50730c 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -2036,6 +2036,7 @@ test socket-14.7.0 {pending [socket -async] and blocking [gets], server is IPv4} } -cleanup { close $fd close $sock + removeFile script } -result {{} ok {}} test socket-14.7.1 {pending [socket -async] and blocking [gets], server is IPv6} \ -constraints {socket supported_inet6 localhost_v6} \ @@ -2056,6 +2057,7 @@ test socket-14.7.1 {pending [socket -async] and blocking [gets], server is IPv6} } -cleanup { close $fd close $sock + removeFile script } -result {{} ok {}} test socket-14.7.2 {pending [socket -async] and blocking [gets], no listener} \ -constraints {socket} \ @@ -2090,6 +2092,7 @@ test socket-14.8.0 {pending [socket -async] and nonblocking [gets], server is IP } -cleanup { close $fd close $sock + removeFile script } -result {ok} test socket-14.8.1 {pending [socket -async] and nonblocking [gets], server is IPv6} \ -constraints {socket supported_inet6 localhost_v6} \ @@ -2115,6 +2118,7 @@ test socket-14.8.1 {pending [socket -async] and nonblocking [gets], server is IP } -cleanup { close $fd close $sock + removeFile script } -result {ok} test socket-14.8.2 {pending [socket -async] and nonblocking [gets], no listener} \ -constraints {socket} \ @@ -2151,6 +2155,7 @@ test socket-14.9.0 {pending [socket -async] and blocking [puts], server is IPv4} } -cleanup { close $fd close $sock + removeFile script } -result {{} ok} test socket-14.9.1 {pending [socket -async] and blocking [puts], server is IPv6} \ -constraints {socket supported_inet6 localhost_v6} \ @@ -2174,6 +2179,7 @@ test socket-14.9.1 {pending [socket -async] and blocking [puts], server is IPv6} } -cleanup { close $fd close $sock + removeFile script } -result {{} ok} test socket-14.10.0 {pending [socket -async] and nonblocking [puts], server is IPv4} \ -constraints {socket supported_inet localhost_v4} \ @@ -2200,6 +2206,7 @@ test socket-14.10.0 {pending [socket -async] and nonblocking [puts], server is I } -cleanup { close $fd close $sock + removeFile script } -result {{} ok} test socket-14.10.1 {pending [socket -async] and nonblocking [puts], server is IPv6} \ -constraints {socket supported_inet6 localhost_v6} \ @@ -2226,6 +2233,7 @@ test socket-14.10.1 {pending [socket -async] and nonblocking [puts], server is I } -cleanup { close $fd close $sock + removeFile script } -result {{} ok} test socket-14.11.0 {pending [socket -async] and nonblocking [puts], no listener, no flush} \ -constraints {socket} \ -- cgit v0.12 From e5eec4e2673a958ea73df11616a148c06adb3db4 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 10 Jul 2014 18:17:28 +0000 Subject: makeFile / removeFile balance. --- tests/ioTrans.test | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/tests/ioTrans.test b/tests/ioTrans.test index c40621b..53078f7 100644 --- a/tests/ioTrans.test +++ b/tests/ioTrans.test @@ -1037,6 +1037,8 @@ test iortrans-11.1 {origin interpreter of moved transform destroyed during acces } -constraints {testchannel} -match glob -body { # Set up channel in thread set chan [interp eval $ida $helperscript] + interp eval $ida [list ::variable tempchan [tempchan]] + interp transfer {} $::tempchan $ida set chan [interp eval $ida { proc foo {args} { handle.initialize clear drain flush limit? read write @@ -1045,7 +1047,7 @@ test iortrans-11.1 {origin interpreter of moved transform destroyed during acces # Destroy interpreter during channel access. suicide } - set chan [chan push [tempchan] foo] + set chan [chan push $tempchan foo] fconfigure $chan -buffering none set chan }] -- cgit v0.12 From fe3773a12fba16561208c2fcfddaccf977bc8073 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 11 Jul 2014 04:49:49 +0000 Subject: [3479689] Plug memory leak due to incomplete bug fix. --- generic/tclPathObj.c | 18 ++++++------------ 1 file changed, 6 insertions(+), 12 deletions(-) diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index fe6063f..99d576d 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -2437,19 +2437,13 @@ SetFsPathFromAny( } TclDecrRefCount(parts); } else { - /* - * Simple case. "rest" is relative path. Just join it. The - * "rest" object will be freed when Tcl_FSJoinToPath returns - * (unless something else claims a refCount on it). - */ - - Tcl_Obj *joined; - Tcl_Obj *rest = Tcl_NewStringObj(name+split+1, -1); + Tcl_Obj *pair[2]; - Tcl_IncrRefCount(transPtr); - joined = Tcl_FSJoinToPath(transPtr, 1, &rest); - TclDecrRefCount(transPtr); - transPtr = joined; + pair[0] = transPtr; + pair[1] = Tcl_NewStringObj(name+split+1, -1); + transPtr = TclJoinPath(2, pair); + Tcl_DecrRefCount(pair[0]); + Tcl_DecrRefCount(pair[1]); } } } else { -- cgit v0.12 From df203baa1f787de574237d71c3df4491edc0dae4 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 11 Jul 2014 10:38:55 +0000 Subject: Starting with Unicode 6.3, the mongolian vowel separator (U+180e) is no longer a whitespace, but for Tcl it still is. "NEL/Next Line" (U+0085) should have been a Unicode whitespace, but never was in Tcl. This is corrected in Tcl 8.6, but for legacy reasons not in Tcl 8.5. Update documentation accordingly, and extend test-cases for Unicode 7 compliance. --- doc/string.n | 3 ++- generic/regc_locale.c | 4 ++-- tests/utf.test | 30 +++++++++++++++--------------- 3 files changed, 19 insertions(+), 18 deletions(-) diff --git a/doc/string.n b/doc/string.n index f39d57c..7e427ab 100644 --- a/doc/string.n +++ b/doc/string.n @@ -161,7 +161,8 @@ Any Unicode printing character, including space. .IP \fBpunct\fR 12 Any Unicode punctuation character. .IP \fBspace\fR 12 -Any Unicode space character. +Any Unicode whitespace character or mongolian vowel separator (U+180e), +but not NEL/Next Line (U+0085). .IP \fBtrue\fR 12 Any of the forms allowed to \fBTcl_GetBoolean\fR where the value is true. diff --git a/generic/regc_locale.c b/generic/regc_locale.c index 8dba520..e056078 100644 --- a/generic/regc_locale.c +++ b/generic/regc_locale.c @@ -381,8 +381,8 @@ static const crange spaceRangeTable[] = { #define NUM_SPACE_RANGE (sizeof(spaceRangeTable)/sizeof(crange)) static const chr spaceCharTable[] = { - 0x20, 0xa0, 0x1680, 0x180e, 0x2028, 0x2029, 0x202f, 0x205f, 0x2060, - 0x3000, 0xfeff + 0x20, 0xa0, 0x1680, 0x180e, 0x2028, 0x2029, 0x202f, 0x205f, + 0x3000 }; #define NUM_SPACE_CHAR (sizeof(spaceCharTable)/sizeof(chr)) diff --git a/tests/utf.test b/tests/utf.test index 35c5f73..30200c1 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -278,15 +278,15 @@ test utf-20.1 {TclUniCharNcmp} { } {} test utf-21.1 {TclUniCharIsAlnum} { - # this returns 1 with Unicode 6 compliance + # this returns 1 with Unicode 7 compliance string is alnum \u1040\u021f\u0220 } {1} test utf-21.2 {unicode alnum char in regc_locale.c} { - # this returns 1 with Unicode 6 compliance + # this returns 1 with Unicode 7 compliance list [regexp {^[[:alnum:]]+$} \u1040\u021f\u0220] [regexp {^\w+$} \u1040\u021f\u0220] } {1 1} test utf-21.3 {unicode print char in regc_locale.c} { - # this returns 1 with Unicode 6 compliance + # this returns 1 with Unicode 7 compliance regexp {^[[:print:]]+$} \ufbc1 } 1 test utf-21.4 {TclUniCharIsGraph} { @@ -319,11 +319,11 @@ test utf-21.10 {unicode print char in regc_locale.c} { } {0} test utf-21.11 {TclUniCharIsControl} { # [Bug 3464428] - string is control \u00ad + string is control \u0000\u001f\u00ad\u0605\u061c\u180e\u2066\ufeff } {1} test utf-21.12 {unicode control char in regc_locale.c} { # [Bug 3464428], [Bug a876646efe] - regexp {^[[:cntrl:]]*$} \u0000\u001f\u00ad + regexp {^[[:cntrl:]]*$} \u0000\u001f\u00ad\u0605\u061c\u180e\u2066\ufeff } {1} test utf-22.1 {TclUniCharIsWordChar} { @@ -334,30 +334,30 @@ test utf-22.2 {TclUniCharIsWordChar} { } 10 test utf-23.1 {TclUniCharIsAlpha} { - # this returns 1 with Unicode 6 compliance - string is alpha \u021f\u0220 + # this returns 1 with Unicode 7 compliance + string is alpha \u021f\u0220\u037f\u052f } {1} test utf-23.2 {unicode alpha char in regc_locale.c} { - # this returns 1 with Unicode 6 compliance - regexp {^[[:alpha:]]+$} \u021f\u0220 + # this returns 1 with Unicode 7 compliance + regexp {^[[:alpha:]]+$} \u021f\u0220\u037f\u052f } {1} test utf-24.1 {TclUniCharIsDigit} { - # this returns 1 with Unicode 6 compliance + # this returns 1 with Unicode 7 compliance string is digit \u1040\uabf0 } {1} test utf-24.2 {unicode digit char in regc_locale.c} { - # this returns 1 with Unicode 6 compliance + # this returns 1 with Unicode 7 compliance list [regexp {^[[:digit:]]+$} \u1040\uabf0] [regexp {^\d+$} \u1040\uabf0] } {1 1} test utf-24.3 {TclUniCharIsSpace} { - # this returns 1 with Unicode 6 compliance - string is space \u1680\u180e + # this returns 1 with Unicode 7 compliance + string is space \u1680\u180e\u202f } {1} test utf-24.4 {unicode space char in regc_locale.c} { - # this returns 1 with Unicode 6 compliance - list [regexp {^[[:space:]]+$} \u1680\u180e] [regexp {^\s+$} \u1680\u180e] + # this returns 1 with Unicode 7 compliance + list [regexp {^[[:space:]]+$} \u1680\u180e\u202f] [regexp {^\s+$} \u1680\u180e\u202f] } {1 1} testConstraint teststringobj [llength [info commands teststringobj]] -- cgit v0.12 From 3088c8e046d26ebc9db26c8f3edffdf32cc327be Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 11 Jul 2014 12:56:16 +0000 Subject: Stop memleak in [info frame]. --- generic/tclCmdIL.c | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index db216e5..f870245 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -1288,6 +1288,9 @@ TclInfoFrame( }; Proc *procPtr = framePtr->framePtr ? framePtr->framePtr->procPtr : NULL; + /* Super ugly hack added to the pile so we can plug memleak */ + int needsFree = -1; + /* * Pull the information and construct the dictionary to return, as list. * Regarding use of the CmdFrame fields see tclInt.h, and its definition. @@ -1360,6 +1363,7 @@ TclInfoFrame( } ADD_PAIR("cmd", TclGetSourceFromFrame(fPtr, 0, NULL)); + needsFree = lc-1; TclStackFree(interp, fPtr); break; } @@ -1447,7 +1451,11 @@ TclInfoFrame( } } - return Tcl_NewListObj(lc, lv); + tmpObj = Tcl_NewListObj(lc, lv); + if (needsFree >= 0) { + Tcl_DecrRefCount(lv[needsFree]); + } + return tmpObj; } /* -- cgit v0.12 From afe83cbf85df2fa657c86e95af1892a567643896 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 11 Jul 2014 15:44:42 +0000 Subject: [9b352768e6] Plug memleak in INST_DICT_FIRST. --- generic/tclExecute.c | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index d8c5935..2f9aac3 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -7474,6 +7474,14 @@ TEBCresume( searchPtr = ckalloc(sizeof(Tcl_DictSearch)); if (Tcl_DictObjFirst(interp, dictPtr, searchPtr, &keyPtr, &valuePtr, &done) != TCL_OK) { + + /* + * dictPtr is no longer on the stack, and we're not + * moving it into the intrep of an iterator. We need + * to drop the refcount [Tcl Bug 9b352768e6]. + */ + + Tcl_DecrRefCount(dictPtr); ckfree(searchPtr); TRACE_ERROR(interp); goto gotError; -- cgit v0.12 From b525ce28bebc490b2cfed08814483e7c88b796a0 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 11 Jul 2014 18:20:42 +0000 Subject: [1211aceef2] Fix refcount management of TclpTempFileName() that caused leak. --- unix/tclUnixPipe.c | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c index a02044e..95bc8d1 100644 --- a/unix/tclUnixPipe.c +++ b/unix/tclUnixPipe.c @@ -229,7 +229,7 @@ TclpCreateTempFile( Tcl_Obj * TclpTempFileName(void) { - Tcl_Obj *nameObj = Tcl_NewObj(); + Tcl_Obj *retVal, *nameObj = Tcl_NewObj(); int fd; Tcl_IncrRefCount(nameObj); @@ -242,7 +242,9 @@ TclpTempFileName(void) fcntl(fd, F_SETFD, FD_CLOEXEC); TclpObjDeleteFile(nameObj); close(fd); - return nameObj; + retVal = Tcl_DuplicateObj(nameObj); + Tcl_DecrRefCount(nameObj); + return retVal; } /* -- cgit v0.12 From 74d71bafde63ca49cecadc990df7b3a2d7797849 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 11 Jul 2014 20:40:24 +0000 Subject: Suppress valgrind warnings about uninitialized values. --- generic/tclDictObj.c | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 3c0ddd8..15fbe1e 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -405,6 +405,7 @@ DupDictInternalRep( */ DICT(copyPtr) = newDict; + copyPtr->internalRep.twoPtrValue.ptr2 = NULL; copyPtr->typePtr = &tclDictType; } @@ -720,6 +721,7 @@ SetDictFromAny( dict->chain = NULL; dict->refcount = 1; DICT(objPtr) = dict; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; objPtr->typePtr = &tclDictType; return TCL_OK; @@ -1390,6 +1392,7 @@ Tcl_NewDictObj(void) dict->chain = NULL; dict->refcount = 1; DICT(dictPtr) = dict; + dictPtr->internalRep.twoPtrValue.ptr2 = NULL; dictPtr->typePtr = &tclDictType; return dictPtr; #endif @@ -1439,6 +1442,7 @@ Tcl_DbNewDictObj( dict->chain = NULL; dict->refcount = 1; DICT(dictPtr) = dict; + dictPtr->internalRep.twoPtrValue.ptr2 = NULL; dictPtr->typePtr = &tclDictType; return dictPtr; #else /* !TCL_MEM_DEBUG */ -- cgit v0.12 From 19e38811559271a3d6c390847ee1f8a206d65a50 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 15 Jul 2014 15:10:32 +0000 Subject: [726349fab8] Stop leaking compression dictionary on zlib xform channel close. --- generic/tclZlib.c | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 4ccda3b..06e18fe 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -2910,6 +2910,10 @@ ZlibTransformClose( * Release all memory. */ + if (cd->compDictObj) { + Tcl_DecrRefCount(cd->compDictObj); + cd->compDictObj = NULL; + } Tcl_DStringFree(&cd->decompressed); if (cd->inBuffer) { -- cgit v0.12 From 54c72fdcab114a768b54bd1dfd06912b79dc0da0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 16 Jul 2014 10:02:02 +0000 Subject: Modify the "gettimes" test-command to use the Tcl_Obj API. New "testbytestring" command which can be used to replace the (to-be-deprecated) "bytestring" command from tcltest and/or the "indentity" encoding. Adapt many testcases to use the "testbytestring" command. --- generic/tclTest.c | 55 ++++++++++++++++++++++++++---- tests/chanio.test | 16 ++++++--- tests/io.test | 12 ++++--- tests/parse.test | 29 ++++++++-------- tests/parseExpr.test | 5 +-- tests/parseOld.test | 13 ++++---- tests/stringObj.test | 17 +++++----- tests/subst.test | 12 ++++--- tests/utf.test | 94 +++++++++++++++++++++++++++------------------------- tests/util.test | 5 +-- 10 files changed, 159 insertions(+), 99 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index a27c95a..0f4b6d4 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -201,8 +201,9 @@ static int EncodingFromUtfProc(ClientData clientData, int *dstCharsPtr); static void ExitProcEven(ClientData clientData); static void ExitProcOdd(ClientData clientData); -static int GetTimesCmd(ClientData clientData, - Tcl_Interp *interp, int argc, const char **argv); +static int GetTimesObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); static void MainLoop(void); static int NoopCmd(ClientData clientData, Tcl_Interp *interp, int argc, const char **argv); @@ -219,6 +220,9 @@ static void SpecialFree(char *blockPtr); static int StaticInitProc(Tcl_Interp *interp); static int TestasyncCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); +static int TestbytestringObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); static int TestcmdinfoCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestcmdtokenCmd(ClientData dummy, @@ -556,9 +560,10 @@ Tcltest_Init( * Create additional commands and math functions for testing Tcl. */ - Tcl_CreateCommand(interp, "gettimes", GetTimesCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "gettimes", GetTimesObjCmd, NULL, NULL); Tcl_CreateCommand(interp, "noop", NoopCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testbytestring", TestbytestringObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testwrongnumargs", TestWrongNumArgsObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd, @@ -4717,7 +4722,7 @@ TestgetvarfullnameCmd( /* *---------------------------------------------------------------------- * - * GetTimesCmd -- + * GetTimesObjCmd -- * * This procedure implements the "gettimes" command. It is used for * computing the time needed for various basic operations such as reading @@ -4733,11 +4738,11 @@ TestgetvarfullnameCmd( */ static int -GetTimesCmd( +GetTimesObjCmd( ClientData unused, /* Unused. */ Tcl_Interp *interp, /* The current interpreter. */ - int argc, /* The number of arguments. */ - const char **argv) /* The argument strings. */ + int notused1, /* Number of arguments. */ + Tcl_Obj *const notused2[]) /* The argument objects. */ { Interp *iPtr = (Interp *) interp; int i, n; @@ -4951,6 +4956,42 @@ NoopObjCmd( /* *---------------------------------------------------------------------- * + * TestbytestringObjCmd -- + * + * This object-based procedure constructs a string which can + * possibly contain invalid UTF-8 bytes. + * + * Results: + * Returns the TCL_OK result code. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestbytestringObjCmd( + ClientData unused, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* The argument objects. */ +{ + int n; + const char *p; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "bytearray"); + return TCL_ERROR; + } + p = (const char *)Tcl_GetByteArrayFromObj(objv[1], &n); + Tcl_SetObjResult(interp, Tcl_NewStringObj(p, n)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TestsetCmd -- * * Implements the "testset{err,noerr}" cmds that are used when testing diff --git a/tests/chanio.test b/tests/chanio.test index e53f059..2738fc6 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -13,10 +13,16 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[catch {package require tcltest 2}]} { - chan puts stderr "Skipping tests in [info script]. tcltest 2 required." - return +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest 2 + namespace import -force ::tcltest::* } + +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + +testConstraint testbytestring [llength [info commands testbytestring]] + namespace eval ::tcl::test::io { namespace import ::tcltest::* @@ -7426,11 +7432,11 @@ test chan-io-59.1 {Thread reference of channels} {testmainthread testchannel} { string equal $result [testmainthread] } {1} -test chan-io-60.1 {writing illegal utf sequences} {openpipe fileevent} { +test chan-io-60.1 {writing illegal utf sequences} {openpipe fileevent testbytestring} { # This test will hang in older revisions of the core. set out [open $path(script) w] chan puts $out { - chan puts [encoding convertfrom identity \xe2] + chan puts [testbytestring \xe2] exit 1 } proc readit {pipe} { diff --git a/tests/io.test b/tests/io.test index a7a666a..bf5adb0 100644 --- a/tests/io.test +++ b/tests/io.test @@ -13,14 +13,16 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[catch {package require tcltest 2}]} { - puts stderr "Skipping tests in [info script]. tcltest 2 required." - return +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest 2 + namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] +testConstraint testbytestring [llength [info commands testbytestring]] + namespace eval ::tcl::test::io { namespace import ::tcltest::* @@ -7860,12 +7862,12 @@ test io-59.1 {Thread reference of channels} {testmainthread testchannel} { string equal $result [testmainthread] } {1} -test io-60.1 {writing illegal utf sequences} {openpipe fileevent} { +test io-60.1 {writing illegal utf sequences} {openpipe fileevent testbytestring} { # This test will hang in older revisions of the core. set out [open $path(script) w] puts $out { - puts [encoding convertfrom identity \xe2] + puts [testbytestring \xe2] exit 1 } proc readit {pipe} { diff --git a/tests/parse.test b/tests/parse.test index 01443c9..fe6026d 100644 --- a/tests/parse.test +++ b/tests/parse.test @@ -20,6 +20,7 @@ namespace eval ::tcl::test::parse { catch [list package require -exact Tcltest [info patchlevel]] testConstraint testparser [llength [info commands testparser]] +testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testevalobjv [llength [info commands testevalobjv]] testConstraint testevalex [llength [info commands testevalex]] testConstraint testparsevarname [llength [info commands testparsevarname]] @@ -29,8 +30,8 @@ testConstraint testcmdtrace [llength [info commands testcmdtrace]] testConstraint testevent [llength [info commands testevent]] testConstraint memory [llength [info commands memory]] -test parse-1.1 {Tcl_ParseCommand procedure, computing string length} testparser { - testparser [bytestring "foo\0 bar"] -1 +test parse-1.1 {Tcl_ParseCommand procedure, computing string length} {testparser testbytestring} { + testparser [testbytestring "foo\0 bar"] -1 } {- foo 1 simple foo 1 text foo 0 {}} test parse-1.2 {Tcl_ParseCommand procedure, computing string length} testparser { testparser "foo bar" -1 @@ -301,9 +302,9 @@ test parse-6.15 {ParseTokens procedure, backslash-newline} testparser { test parse-6.16 {ParseTokens procedure, backslash substitution} testparser { testparser {\n\a\x7f} 0 } {- {\n\a\x7f} 1 word {\n\a\x7f} 3 backslash {\n} 0 backslash {\a} 0 backslash {\x7f} 0 {}} -test parse-6.17 {ParseTokens procedure, null characters} testparser { - testparser [bytestring "foo\0zz"] 0 -} "- [bytestring foo\0zz] 1 word [bytestring foo\0zz] 3 text foo 0 text [bytestring \0] 0 text zz 0 {}" +test parse-6.17 {ParseTokens procedure, null characters} {testparser testbytestring} { + testparser [testbytestring "foo\0zz"] 0 +} "- [testbytestring foo\0zz] 1 word [testbytestring foo\0zz] 3 text foo 0 text [testbytestring \0] 0 text zz 0 {}" test parse-6.18 {ParseTokens procedure, seek past numBytes for close-bracket} testparser { # Test for Bug 681841 list [catch {testparser {[a]} 2} msg] $msg @@ -700,8 +701,8 @@ test parse-13.6 {Tcl_ParseVar memory leak} -constraints memory -setup { rename getbytes {} } -result 0 -test parse-14.1 {Tcl_ParseBraces procedure, computing string length} testparser { - testparser [bytestring "foo\0 bar"] -1 +test parse-14.1 {Tcl_ParseBraces procedure, computing string length} {testparser testbytestring} { + testparser [testbytestring "foo\0 bar"] -1 } {- foo 1 simple foo 1 text foo 0 {}} test parse-14.2 {Tcl_ParseBraces procedure, computing string length} testparser { testparser "foo bar" -1 @@ -737,8 +738,8 @@ test parse-14.12 {Tcl_ParseBraces procedure, missing close brace} testparser { list [catch {testparser "foo \{xy\\\nz" 0} msg] $msg $::errorInfo } {1 {missing close-brace} missing\ close-brace\n\ \ \ \ (remainder\ of\ script:\ \"\{xy\\\nz\")\n\ \ \ \ invoked\ from\ within\n\"testparser\ \"foo\ \\\{xy\\\\\\nz\"\ 0\"} -test parse-15.1 {Tcl_ParseQuotedString procedure, computing string length} testparser { - testparser [bytestring "foo\0 bar"] -1 +test parse-15.1 {Tcl_ParseQuotedString procedure, computing string length} {testparser testbytestring} { + testparser [testbytestring "foo\0 bar"] -1 } {- foo 1 simple foo 1 text foo 0 {}} test parse-15.2 {Tcl_ParseQuotedString procedure, computing string length} testparser { testparser "foo bar" -1 @@ -903,11 +904,11 @@ test parse-15.53 {CommandComplete procedure} " test parse-15.54 {CommandComplete procedure} " info complete \"foo bar;# \{\" " 1 -test parse-15.55 {CommandComplete procedure} { - info complete "set x [bytestring \0]; puts hi" +test parse-15.55 {CommandComplete procedure} testbytestring { + info complete "set x [testbytestring \0]; puts hi" } 1 -test parse-15.56 {CommandComplete procedure} { - info complete "set x [bytestring \0]; \{" +test parse-15.56 {CommandComplete procedure} testbytestring { + info complete "set x [testbytestring \0]; \{" } 0 test parse-15.57 {CommandComplete procedure} { info complete "# Comment should be complete command" @@ -917,7 +918,7 @@ test parse-15.58 {CommandComplete procedure, memory leaks} { } 1 test parse-15.59 {CommandComplete procedure} { # Test for Tcl Bug 684744 - info complete [encoding convertfrom identity "\x00;if 1 \{"] + info complete [testbytestring "\x00;if 1 \{"] } 0 test parse-15.60 {CommandComplete procedure} { # Test for Tcl Bug 1968882 diff --git a/tests/parseExpr.test b/tests/parseExpr.test index 714c45b..5c7986a 100644 --- a/tests/parseExpr.test +++ b/tests/parseExpr.test @@ -20,6 +20,7 @@ catch [list package require -exact Tcltest [info patchlevel]] # of "<<" are integers. testConstraint testexprparser [llength [info commands testexprparser]] +testConstraint testbytestring [llength [info commands testbytestring]] # Big test for correct ordering of data in [expr] @@ -81,8 +82,8 @@ testConstraint ieeeFloatingPoint [testIEEE] ###################################################################### -test parseExpr-1.1 {Tcl_ParseExpr procedure, computing string length} testexprparser { - testexprparser [bytestring "1+2\0 +3"] -1 +test parseExpr-1.1 {Tcl_ParseExpr procedure, computing string length} {testexprparser testbytestring} { + testexprparser [testbytestring "1+2\0 +3"] -1 } {- {} 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}} test parseExpr-1.2 {Tcl_ParseExpr procedure, computing string length} testexprparser { testexprparser "1 + 2" -1 diff --git a/tests/parseOld.test b/tests/parseOld.test index f3b1591..4c08b5d 100644 --- a/tests/parseOld.test +++ b/tests/parseOld.test @@ -20,6 +20,7 @@ namespace import ::tcltest::* catch [list package require -exact Tcltest [info patchlevel]] testConstraint testwordend [llength [info commands testwordend]] +testConstraint testbytestring [llength [info commands testbytestring]] # Save the argv value for restoration later set savedArgv $argv @@ -261,15 +262,15 @@ test parseOld-7.10 {backslash substitution} { test parseOld-7.11 {backslash substitution} { eval "list a \"b c\"\\\nd e" } {a {b c} d e} -test parseOld-7.12 {backslash substitution} { +test parseOld-7.12 {backslash substitution} testbytestring { list \ua2 -} [bytestring "\xc2\xa2"] -test parseOld-7.13 {backslash substitution} { +} [testbytestring "\xc2\xa2"] +test parseOld-7.13 {backslash substitution} testbytestring { list \u4e21 -} [bytestring "\xe4\xb8\xa1"] -test parseOld-7.14 {backslash substitution} { +} [testbytestring "\xe4\xb8\xa1"] +test parseOld-7.14 {backslash substitution} testbytestring { list \u4e2k -} [bytestring "\xd3\xa2k"] +} [testbytestring "\xd3\xa2k"] # Semi-colon. diff --git a/tests/stringObj.test b/tests/stringObj.test index 6f331d3..ec7b819 100644 --- a/tests/stringObj.test +++ b/tests/stringObj.test @@ -21,6 +21,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { catch [list package require -exact Tcltest [info patchlevel]] testConstraint testobj [llength [info commands testobj]] +testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testdstring [llength [info commands testdstring]] test stringObj-1.1 {string type registration} testobj { @@ -338,7 +339,7 @@ test stringObj-10.2 {Tcl_GetRange with some mixed width chars} {testobj testdstr # Because this test does not use \uXXXX notation below instead of # hardcoding the values, it may fail in multibyte locales. However, we # need to test that the parser produces untyped objects even when there - # are high-ASCII characters in the input (like "ï"). I don't know what + # are high-ASCII characters in the input (like "�"). I don't know what # else to do but inline those characters here. testdstring free testdstring append "abc\u00ef\u00efdef" -1 @@ -347,7 +348,7 @@ test stringObj-10.2 {Tcl_GetRange with some mixed width chars} {testobj testdstr [testobj objtype $x] [testobj objtype $y] } [list none "bc\u00EF\u00EFde" string string] test stringObj-10.3 {Tcl_GetRange with some mixed width chars} testobj { - # set x "abcïïdef" + # set x "abc��def" # Use \uXXXX notation below instead of hardcoding the values, otherwise # the test will fail in multibyte locales. set x "abc\u00EF\u00EFdef" @@ -356,7 +357,7 @@ test stringObj-10.3 {Tcl_GetRange with some mixed width chars} testobj { [testobj objtype $x] [testobj objtype $y] } [list string "bc\u00EF\u00EFde" string string] test stringObj-10.4 {Tcl_GetRange with some mixed width chars} testobj { - # set a "ïa¿b®cï¿d®" + # set a "�a�b�c�d�" # Use \uXXXX notation below instead of hardcoding the values, otherwise # the test will fail in multibyte locales. set a "\u00EFa\u00BFb\u00AEc\u00EF\u00BFd\u00AE" @@ -422,18 +423,18 @@ test stringObj-13.5 {Tcl_GetCharLength with mixed width chars} testobj { string length "\u00EF\u00BF\u00AE\u00EF\u00BF\u00AE" } 6 test stringObj-13.6 {Tcl_GetCharLength with mixed width chars} testobj { - # set a "ïa¿b®cï¿d®" + # set a "�a�b�c�d�" # Use \uXXXX notation below instead of hardcoding the values, otherwise # the test will fail in multibyte locales. set a "\u00EFa\u00BFb\u00AEc\u00EF\u00BFd\u00AE" list [string length $a] [string length $a] } {10 10} -test stringObj-13.7 {Tcl_GetCharLength with identity nulls} testobj { +test stringObj-13.7 {Tcl_GetCharLength with identity nulls} {testobj testbytestring} { # SF bug #684699 - string length [encoding convertfrom identity \x00] + string length [testbytestring \x00] } 1 -test stringObj-13.8 {Tcl_GetCharLength with identity nulls} testobj { - string length [encoding convertfrom identity \x01\x00\x02] +test stringObj-13.8 {Tcl_GetCharLength with identity nulls} {testobj testbytestring} { + string length [testbytestring \x01\x00\x02] } 3 test stringObj-14.1 {Tcl_SetObjLength on pure unicode object} testobj { diff --git a/tests/subst.test b/tests/subst.test index 498512d..747438e 100644 --- a/tests/subst.test +++ b/tests/subst.test @@ -15,6 +15,10 @@ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + +testConstraint testbytestring [llength [info commands testbytestring]] test subst-1.1 {basics} -returnCodes error -body { subst @@ -32,16 +36,16 @@ test subst-2.2 {simple strings} { test subst-2.3 {simple strings} { subst abcdefg } abcdefg -test subst-2.4 {simple strings} { +test subst-2.4 {simple strings} testbytestring { # Tcl Bug 685106 - subst [bytestring bar\x00soom] -} [bytestring bar\x00soom] + subst [testbytestring bar\x00soom] +} [testbytestring bar\x00soom] test subst-3.1 {backslash substitutions} { subst {\x\$x\[foo bar]\\} } "x\$x\[foo bar]\\" test subst-3.2 {backslash substitutions with utf chars} { - # 'j' is just a char that doesn't mean anything, and \344 is 'ä' + # 'j' is just a char that doesn't mean anything, and \344 is '�' # that also doesn't mean anything, but is multi-byte in UTF-8. list [subst \j] [subst \\j] [subst \\344] [subst \\\344] } "j j \344 \344" diff --git a/tests/utf.test b/tests/utf.test index 2d62fa0..2fcac49 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -16,50 +16,52 @@ if {[lsearch [namespace children] ::tcltest] == -1} { ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] +testConstraint testbytestring [llength [info commands testbytestring]] + catch {unset x} -test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} { +test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} testbytestring { set x \x01 -} [bytestring "\x01"] -test utf-1.2 {Tcl_UniCharToUtf: 2 byte sequences} { +} [testbytestring "\x01"] +test utf-1.2 {Tcl_UniCharToUtf: 2 byte sequences} testbytestring { set x "\x00" -} [bytestring "\xc0\x80"] -test utf-1.3 {Tcl_UniCharToUtf: 2 byte sequences} { +} [testbytestring "\xc0\x80"] +test utf-1.3 {Tcl_UniCharToUtf: 2 byte sequences} testbytestring { set x "\xe0" -} [bytestring "\xc3\xa0"] -test utf-1.4 {Tcl_UniCharToUtf: 3 byte sequences} { +} [testbytestring "\xc3\xa0"] +test utf-1.4 {Tcl_UniCharToUtf: 3 byte sequences} testbytestring { set x "\u4e4e" -} [bytestring "\xe4\xb9\x8e"] -test utf-1.5 {Tcl_UniCharToUtf: overflowed Tcl_UniChar} { +} [testbytestring "\xe4\xb9\x8e"] +test utf-1.5 {Tcl_UniCharToUtf: overflowed Tcl_UniChar} testbytestring { format %c 0x110000 -} [bytestring "\xef\xbf\xbd"] -test utf-1.6 {Tcl_UniCharToUtf: negative Tcl_UniChar} { +} [testbytestring "\xef\xbf\xbd"] +test utf-1.6 {Tcl_UniCharToUtf: negative Tcl_UniChar} testbytestring { format %c -1 -} [bytestring "\xef\xbf\xbd"] +} [testbytestring "\xef\xbf\xbd"] test utf-2.1 {Tcl_UtfToUniChar: low ascii} { string length "abc" } {3} -test utf-2.2 {Tcl_UtfToUniChar: naked trail bytes} { - string length [bytestring "\x82\x83\x84"] +test utf-2.2 {Tcl_UtfToUniChar: naked trail bytes} testbytestring { + string length [testbytestring "\x82\x83\x84"] } {3} -test utf-2.3 {Tcl_UtfToUniChar: lead (2-byte) followed by non-trail} { - string length [bytestring "\xC2"] +test utf-2.3 {Tcl_UtfToUniChar: lead (2-byte) followed by non-trail} testbytestring { + string length [testbytestring "\xC2"] } {1} -test utf-2.4 {Tcl_UtfToUniChar: lead (2-byte) followed by trail} { - string length [bytestring "\xC2\xa2"] +test utf-2.4 {Tcl_UtfToUniChar: lead (2-byte) followed by trail} testbytestring { + string length [testbytestring "\xC2\xa2"] } {1} -test utf-2.5 {Tcl_UtfToUniChar: lead (3-byte) followed by non-trail} { - string length [bytestring "\xE2"] +test utf-2.5 {Tcl_UtfToUniChar: lead (3-byte) followed by non-trail} testbytestring { + string length [testbytestring "\xE2"] } {1} -test utf-2.6 {Tcl_UtfToUniChar: lead (3-byte) followed by 1 trail} { - string length [bytestring "\xE2\xA2"] +test utf-2.6 {Tcl_UtfToUniChar: lead (3-byte) followed by 1 trail} testbytestring { + string length [testbytestring "\xE2\xA2"] } {2} -test utf-2.7 {Tcl_UtfToUniChar: lead (3-byte) followed by 2 trail} { - string length [bytestring "\xE4\xb9\x8e"] +test utf-2.7 {Tcl_UtfToUniChar: lead (3-byte) followed by 2 trail} testbytestring { + string length [testbytestring "\xE4\xb9\x8e"] } {1} -test utf-2.8 {Tcl_UtfToUniChar: longer UTF sequences not supported} { - string length [bytestring "\xF4\xA2\xA2\xA2"] +test utf-2.8 {Tcl_UtfToUniChar: longer UTF sequences not supported} testbytestring { + string length [testbytestring "\xF4\xA2\xA2\xA2"] } {4} test utf-3.1 {Tcl_UtfCharComplete} { @@ -69,26 +71,26 @@ testConstraint testnumutfchars [llength [info commands testnumutfchars]] test utf-4.1 {Tcl_NumUtfChars: zero length} testnumutfchars { testnumutfchars "" } {0} -test utf-4.2 {Tcl_NumUtfChars: length 1} testnumutfchars { - testnumutfchars [bytestring "\xC2\xA2"] +test utf-4.2 {Tcl_NumUtfChars: length 1} {testnumutfchars testbytestring} { + testnumutfchars [testbytestring "\xC2\xA2"] } {1} -test utf-4.3 {Tcl_NumUtfChars: long string} testnumutfchars { - testnumutfchars [bytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e4e"] +test utf-4.3 {Tcl_NumUtfChars: long string} {testnumutfchars testbytestring} { + testnumutfchars [testbytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e4e"] } {7} -test utf-4.4 {Tcl_NumUtfChars: #u0000} testnumutfchars { - testnumutfchars [bytestring "\xC0\x80"] +test utf-4.4 {Tcl_NumUtfChars: #u0000} {testnumutfchars testbytestring} { + testnumutfchars [testbytestring "\xC0\x80"] } {1} test utf-4.5 {Tcl_NumUtfChars: zero length, calc len} testnumutfchars { testnumutfchars "" 1 } {0} -test utf-4.6 {Tcl_NumUtfChars: length 1, calc len} testnumutfchars { - testnumutfchars [bytestring "\xC2\xA2"] 1 +test utf-4.6 {Tcl_NumUtfChars: length 1, calc len} {testnumutfchars testbytestring} { + testnumutfchars [testbytestring "\xC2\xA2"] 1 } {1} -test utf-4.7 {Tcl_NumUtfChars: long string, calc len} testnumutfchars { - testnumutfchars [bytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e4e"] 1 +test utf-4.7 {Tcl_NumUtfChars: long string, calc len} {testnumutfchars testbytestring} { + testnumutfchars [testbytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e4e"] 1 } {7} -test utf-4.8 {Tcl_NumUtfChars: #u0000, calc len} testnumutfchars { - testnumutfchars [bytestring "\xC0\x80"] 1 +test utf-4.8 {Tcl_NumUtfChars: #u0000, calc len} {testnumutfchars testbytestring} { + testnumutfchars [testbytestring "\xC0\x80"] 1 } {1} test utf-5.1 {Tcl_UtfFindFirsts} { @@ -125,18 +127,18 @@ test utf-10.1 {Tcl_UtfBackslash: dst == NULL} { set x \n } { } -test utf-10.2 {Tcl_UtfBackslash: \u subst} { +test utf-10.2 {Tcl_UtfBackslash: \u subst} testbytestring { set x \ua2 -} [bytestring "\xc2\xa2"] -test utf-10.3 {Tcl_UtfBackslash: longer \u subst} { +} [testbytestring "\xc2\xa2"] +test utf-10.3 {Tcl_UtfBackslash: longer \u subst} testbytestring { set x \u4e21 -} [bytestring "\xe4\xb8\xa1"] -test utf-10.4 {Tcl_UtfBackslash: stops at first non-hex} { +} [testbytestring "\xe4\xb8\xa1"] +test utf-10.4 {Tcl_UtfBackslash: stops at first non-hex} testbytestring { set x \u4e2k -} "[bytestring \xd3\xa2]k" -test utf-10.5 {Tcl_UtfBackslash: stops after 4 hex chars} { +} "[testbytestring \xd3\xa2]k" +test utf-10.5 {Tcl_UtfBackslash: stops after 4 hex chars} testbytestring { set x \u4e216 -} "[bytestring \xe4\xb8\xa1]6" +} "[testbytestring \xe4\xb8\xa1]6" proc bsCheck {char num} { global errNum test utf-10.$errNum {backslash substitution} { diff --git a/tests/util.test b/tests/util.test index 0e50483..7782f35 100644 --- a/tests/util.test +++ b/tests/util.test @@ -16,6 +16,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { catch [list package require -exact Tcltest [info patchlevel]] testConstraint controversialNaN 1 +testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testdstring [llength [info commands testdstring]] testConstraint testconcatobj [llength [info commands testconcatobj]] testConstraint testdoubledigits [llength [info commands testdoubledigits]] @@ -274,10 +275,10 @@ test util-5.17 {Tcl_StringMatch: UTF-8} { # get 1 UTF-8 character Wrapper_Tcl_StringMatch "a\[a\u4e4fc]c" "a\u4e4fc" } 1 -test util-5.18 {Tcl_StringMatch: UTF-8} { +test util-5.18 {Tcl_StringMatch: UTF-8} testbytestring { # pattern += Tcl_UtfToUniChar(pattern, &endChar); # proper advance: wrong answer would match on UTF trail byte of \u4e4f - Wrapper_Tcl_StringMatch {a[a\u4e4fc]c} [bytestring a\u008fc] + Wrapper_Tcl_StringMatch {a[a\u4e4fc]c} [testbytestring a\u008fc] } 0 test util-5.19 {Tcl_StringMatch: UTF-8} { # pattern += Tcl_UtfToUniChar(pattern, &endChar); -- cgit v0.12 From 7fd0e62dc493b5523e14818c9d424b1c5ef91d3e Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 16 Jul 2014 15:59:00 +0000 Subject: [6a2d339e50] Plug memleak in INST_STR_REPLACE instruction. --- generic/tclExecute.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 2f9aac3..0d485c2 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5601,6 +5601,7 @@ TEBCresume( ((int *) objResultPtr->internalRep.otherValuePtr)[1] = 0; } Tcl_InvalidateStringRep(objResultPtr); + TclDecrRefCount(value3Ptr); TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } else { @@ -5627,6 +5628,7 @@ TEBCresume( ((int *) objResultPtr->internalRep.otherValuePtr)[1] = 0; } Tcl_InvalidateStringRep(valuePtr); + TclDecrRefCount(value3Ptr); TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } -- cgit v0.12 From 5ca125c7ce857abbf0ff4b47b60a1853b28759a1 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 16 Jul 2014 21:46:30 +0000 Subject: Assert an equality test, not an assignment. --- generic/regc_nfa.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/regc_nfa.c b/generic/regc_nfa.c index 2fc3a05..2de7e14 100644 --- a/generic/regc_nfa.c +++ b/generic/regc_nfa.c @@ -1332,7 +1332,7 @@ fixempties( for (s = nfa->states; s != NULL && !NISERR(); s = nexts) { nexts = s->next; /* Ensure tmp fields are clear for next step */ - assert(s->tmp = NULL); + assert(s->tmp == NULL); if (s->flag || s->nins != 1) { continue; } -- cgit v0.12 From 8545051315841a4c5671ceb49710eb176012d8cc Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 16 Jul 2014 22:01:57 +0000 Subject: Repair improper assertion. --- generic/tclCmdIL.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index f870245..99d9332 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -2663,7 +2663,7 @@ Tcl_LrepeatObjCmd( * number of times. */ - CLANG_ASSERT(dataArray); + CLANG_ASSERT(dataArray || totalElems == 0 ); if (objc == 1) { register Tcl_Obj *tmpPtr = objv[0]; -- cgit v0.12 From c0f4026d88454c1460a3b0905cb41ee61a16ad1a Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 16 Jul 2014 23:58:54 +0000 Subject: Backout checkin that broke test io-39.1. --- generic/tclCmdIL.c | 10 +--------- 1 file changed, 1 insertion(+), 9 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 99d9332..a26d6cc 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -1288,9 +1288,6 @@ TclInfoFrame( }; Proc *procPtr = framePtr->framePtr ? framePtr->framePtr->procPtr : NULL; - /* Super ugly hack added to the pile so we can plug memleak */ - int needsFree = -1; - /* * Pull the information and construct the dictionary to return, as list. * Regarding use of the CmdFrame fields see tclInt.h, and its definition. @@ -1363,7 +1360,6 @@ TclInfoFrame( } ADD_PAIR("cmd", TclGetSourceFromFrame(fPtr, 0, NULL)); - needsFree = lc-1; TclStackFree(interp, fPtr); break; } @@ -1451,11 +1447,7 @@ TclInfoFrame( } } - tmpObj = Tcl_NewListObj(lc, lv); - if (needsFree >= 0) { - Tcl_DecrRefCount(lv[needsFree]); - } - return tmpObj; + return Tcl_NewListObj(lc, lv); } /* -- cgit v0.12 From f6c6b8c696a065866d6d0a7e6b844cda57916322 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 17 Jul 2014 04:24:23 +0000 Subject: [9969cf8ca6] Move the bailout when the ->rewind flag is set down after all the housekeeping matters tearing down frames (trace data) is complete. --- generic/tclExecute.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 0d485c2..0cd074d 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2204,10 +2204,6 @@ TEBCresume( } else { /* resume from invocation */ CACHE_STACK_INFO(); - if (iPtr->execEnvPtr->rewind) { - result = TCL_ERROR; - goto abnormalReturn; - } NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr); if (bcFramePtr->cmdObj) { @@ -2219,6 +2215,10 @@ TEBCresume( if (iPtr->flags & INTERP_DEBUG_FRAME) { TclArgumentBCRelease(interp, bcFramePtr); } + if (iPtr->execEnvPtr->rewind) { + result = TCL_ERROR; + goto abnormalReturn; + } if (codePtr->flags & TCL_BYTECODE_RECOMPILE) { iPtr->flags |= ERR_ALREADY_LOGGED; codePtr->flags &= ~TCL_BYTECODE_RECOMPILE; -- cgit v0.12 From 81f6450e303c90f6d48445856752ddaa52436954 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 17 Jul 2014 07:39:00 +0000 Subject: Convert some non-ASCII characters in testcase comments - which were mangled by my editor in [79ace7b793] - to valid UTF-8: This way my editor will not mangle them again, and fossil will show in the UI which characters are supposed to be there. --- tests/stringObj.test | 12 ++++++------ tests/subst.test | 2 +- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/tests/stringObj.test b/tests/stringObj.test index ec7b819..8209142 100644 --- a/tests/stringObj.test +++ b/tests/stringObj.test @@ -339,7 +339,7 @@ test stringObj-10.2 {Tcl_GetRange with some mixed width chars} {testobj testdstr # Because this test does not use \uXXXX notation below instead of # hardcoding the values, it may fail in multibyte locales. However, we # need to test that the parser produces untyped objects even when there - # are high-ASCII characters in the input (like "�"). I don't know what + # are high-ASCII characters in the input (like "ï"). I don't know what # else to do but inline those characters here. testdstring free testdstring append "abc\u00ef\u00efdef" -1 @@ -348,7 +348,7 @@ test stringObj-10.2 {Tcl_GetRange with some mixed width chars} {testobj testdstr [testobj objtype $x] [testobj objtype $y] } [list none "bc\u00EF\u00EFde" string string] test stringObj-10.3 {Tcl_GetRange with some mixed width chars} testobj { - # set x "abc��def" + # set x "abcïïdef" # Use \uXXXX notation below instead of hardcoding the values, otherwise # the test will fail in multibyte locales. set x "abc\u00EF\u00EFdef" @@ -357,7 +357,7 @@ test stringObj-10.3 {Tcl_GetRange with some mixed width chars} testobj { [testobj objtype $x] [testobj objtype $y] } [list string "bc\u00EF\u00EFde" string string] test stringObj-10.4 {Tcl_GetRange with some mixed width chars} testobj { - # set a "�a�b�c�d�" + # set a "ïa¿b®cï¿d®" # Use \uXXXX notation below instead of hardcoding the values, otherwise # the test will fail in multibyte locales. set a "\u00EFa\u00BFb\u00AEc\u00EF\u00BFd\u00AE" @@ -417,13 +417,13 @@ test stringObj-13.4 {Tcl_GetCharLength with mixed width chars} testobj { string length "\u00ae" } 1 test stringObj-13.5 {Tcl_GetCharLength with mixed width chars} testobj { - # string length "￮￮" + # string length "￮￮" # Use \uXXXX notation below instead of hardcoding the values, otherwise # the test will fail in multibyte locales. string length "\u00EF\u00BF\u00AE\u00EF\u00BF\u00AE" } 6 test stringObj-13.6 {Tcl_GetCharLength with mixed width chars} testobj { - # set a "�a�b�c�d�" + # set a "ïa¿b®cï¿d®" # Use \uXXXX notation below instead of hardcoding the values, otherwise # the test will fail in multibyte locales. set a "\u00EFa\u00BFb\u00AEc\u00EF\u00BFd\u00AE" @@ -433,7 +433,7 @@ test stringObj-13.7 {Tcl_GetCharLength with identity nulls} {testobj testbytestr # SF bug #684699 string length [testbytestring \x00] } 1 -test stringObj-13.8 {Tcl_GetCharLength with identity nulls} {testobj testbytestring} { +test stringObj-13.8 {Tcl_GetCharLength with identity nulls} {testobj testbytestring} { string length [testbytestring \x01\x00\x02] } 3 diff --git a/tests/subst.test b/tests/subst.test index 747438e..256b7f7 100644 --- a/tests/subst.test +++ b/tests/subst.test @@ -45,7 +45,7 @@ test subst-3.1 {backslash substitutions} { subst {\x\$x\[foo bar]\\} } "x\$x\[foo bar]\\" test subst-3.2 {backslash substitutions with utf chars} { - # 'j' is just a char that doesn't mean anything, and \344 is '�' + # 'j' is just a char that doesn't mean anything, and \344 is 'ä' # that also doesn't mean anything, but is multi-byte in UTF-8. list [subst \j] [subst \\j] [subst \\344] [subst \\\344] } "j j \344 \344" -- cgit v0.12 From f9efaaa3654408f97cb74fdac4b1309b067f7e71 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 17 Jul 2014 11:02:03 +0000 Subject: Fix [3cdcfa40809ffd2b9d3d71f77dc57da615243730|3cdcfa4080]: tclWinFile.c does not compile with Win VC6 --- win/tclWinFile.c | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/win/tclWinFile.c b/win/tclWinFile.c index ad4a5c4..1cdd53f 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -2900,7 +2900,7 @@ TclNativeCreateNativeRep( WCHAR *nativePathPtr; const char *str; Tcl_Obj *validPathPtr; - int len; + size_t len; WCHAR *wp; if (TclFSCwdIsNative()) { @@ -2926,7 +2926,8 @@ TclNativeCreateNativeRep( Tcl_IncrRefCount(validPathPtr); } - str = Tcl_GetStringFromObj(validPathPtr, &len); + str = Tcl_GetString(validPathPtr); + len = validPathPtr->length; if (strlen(str)!=len) { /* String contains NUL-bytes. This is invalid. */ -- cgit v0.12 From 88075c1802796846a7bdf280387225202dd7ec99 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 17 Jul 2014 14:08:30 +0000 Subject: Make sure that all "testchmod" arguments start with '0', making it more obvious that the value is octal. dgp: Isn't the better way to make it obvious the values are octal to use the explicit octal notation? For example, [testchmod 0o777 $path] ? Really seems like a bad idea to me to introduce *more* incompatibilities for the planned conversion for having the value 0777 stop meaning 255 and start meaning 777 in Tcl 9. Answer (Jan). You guessed exactly what's my follow-up plan. This was an intermediate step which keeps all test-cases running. --- tests/fCmd.test | 86 ++++++++++++++++++++++++++--------------------------- tests/tcltest.test | 36 +++++++++++----------- tests/unixFCmd.test | 2 +- tests/winFCmd.test | 46 ++++++++++++++-------------- 4 files changed, 85 insertions(+), 85 deletions(-) diff --git a/tests/fCmd.test b/tests/fCmd.test index 5836e00..c479e35 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.test @@ -128,7 +128,7 @@ proc checkcontent {file matchString} { } proc openup {path} { - testchmod 777 $path + testchmod 0777 $path if {[file isdirectory $path]} { catch { foreach p [glob -directory $path *] { @@ -362,10 +362,10 @@ test fCmd-4.11 {TclFileMakeDirsCmd: doesn't exist: errno != ENOENT} -setup { cleanup } -constraints {unix notRoot testchmod} -returnCodes error -body { file mkdir td1/td2/td3 - testchmod 000 td1/td2 + testchmod 0 td1/td2 file mkdir td1/td2/td3/td4 } -cleanup { - testchmod 755 td1/td2 + testchmod 0755 td1/td2 cleanup } -result {can't create directory "td1/td2/td3": permission denied} test fCmd-4.13 {TclFileMakeDirsCmd: doesn't exist: errno == ENOENT} -setup { @@ -505,11 +505,11 @@ test fCmd-6.6 {CopyRenameOneFile: errno != ENOENT} -setup { cleanup } -constraints {unix notRoot testchmod} -body { file mkdir td1 - testchmod 000 td1 + testchmod 0 td1 createfile tf1 file rename tf1 td1 } -returnCodes error -cleanup { - testchmod 755 td1 + testchmod 0755 td1 } -result {error renaming "tf1" to "td1/tf1": permission denied} test fCmd-6.9 {CopyRenameOneFile: errno == ENOENT} -setup { cleanup @@ -785,7 +785,7 @@ test fCmd-9.3 {file rename: comprehensive: file to new name} -setup { } -constraints {notRoot testchmod} -body { createfile tf1 createfile tf2 - testchmod 444 tf2 + testchmod 0444 tf2 file rename tf1 tf3 file rename tf2 tf4 list [lsort [glob tf*]] [file writable tf3] [file writable tf4] @@ -794,7 +794,7 @@ test fCmd-9.4.a {file rename: comprehensive: dir to new name} -setup { cleanup } -constraints {win win2000orXP testchmod} -body { file mkdir td1 td2 - testchmod 555 td2 + testchmod 0555 td2 file rename td1 td3 file rename td2 td4 list [lsort [glob td*]] [file writable td3] [file writable td4] @@ -805,7 +805,7 @@ test fCmd-9.4.b {file rename: comprehensive: dir to new name} -setup { cleanup } -constraints {unix notRoot testchmod notDarwin9} -body { file mkdir td1 td2 - testchmod 555 td2 + testchmod 0555 td2 file rename td1 td3 file rename td2 td4 list [lsort [glob td*]] [file writable td3] [file writable td4] @@ -817,7 +817,7 @@ test fCmd-9.5 {file rename: comprehensive: file to self} -setup { } -constraints {notRoot testchmod} -body { createfile tf1 tf1 createfile tf2 tf2 - testchmod 444 tf2 + testchmod 0444 tf2 file rename -force tf1 tf1 file rename -force tf2 tf2 list [contents tf1] [contents tf2] [file writable tf1] [file writable tf2] @@ -827,7 +827,7 @@ test fCmd-9.6.a {file rename: comprehensive: dir to self} -setup { } -constraints {win win2000orXP testchmod} -body { file mkdir td1 file mkdir td2 - testchmod 555 td2 + testchmod 0555 td2 file rename -force td1 . file rename -force td2 . list [lsort [glob td*]] [file writable td1] [file writable td2] @@ -837,7 +837,7 @@ test fCmd-9.6.b {file rename: comprehensive: dir to self} -setup { } -constraints {unix notRoot testchmod} -body { file mkdir td1 file mkdir td2 - testchmod 555 td2 + testchmod 0555 td2 file rename -force td1 . file rename -force td2 . list [lsort [glob td*]] [file writable td1] [file writable td2] @@ -855,10 +855,10 @@ test fCmd-9.7 {file rename: comprehensive: file to existing file} -setup { createfile tfd2 createfile tfd3 createfile tfd4 - testchmod 444 tfs3 - testchmod 444 tfs4 - testchmod 444 tfd2 - testchmod 444 tfd4 + testchmod 0444 tfs3 + testchmod 0444 tfs4 + testchmod 0444 tfd2 + testchmod 0444 tfd4 set msg [list [catch {file rename tf1 tf2} msg] $msg] file rename -force tfs1 tfd1 file rename -force tfs2 tfd2 @@ -882,11 +882,11 @@ test fCmd-9.8 {file rename: comprehensive: dir to empty dir} -setup { file mkdir [file join tdd3 tds3] file mkdir [file join tdd4 tds4] if {![testConstraint unix]} { - testchmod 555 tds3 - testchmod 555 tds4 + testchmod 0555 tds3 + testchmod 0555 tds4 } - testchmod 555 [file join tdd2 tds2] - testchmod 555 [file join tdd4 tds4] + testchmod 0555 [file join tdd2 tds2] + testchmod 0555 [file join tdd4 tds4] set msg [list [catch {file rename td1 td2} msg] $msg] file rename -force tds1 tdd1 file rename -force tds2 tdd2 @@ -911,7 +911,7 @@ test fCmd-9.9 {file rename: comprehensive: dir to non-empty dir} -setup { file mkdir [file join tdd1 tds1 xxx] file mkdir [file join tdd2 tds2 xxx] if {!([testConstraint unix] || [testConstraint winVista])} { - testchmod 555 tds2 + testchmod 0555 tds2 } set a1 [list [catch {file rename -force tds1 tdd1} msg] $msg] set a2 [list [catch {file rename -force tds2 tdd2} msg] $msg] @@ -929,7 +929,7 @@ test fCmd-9.10 {file rename: comprehensive: file to new name and dir} -setup { createfile tf1 createfile tf2 file mkdir td1 - testchmod 444 tf2 + testchmod 0444 tf2 file rename tf1 [file join td1 tf3] file rename tf2 [file join td1 tf4] list [catch {glob tf*}] [lsort [glob -directory td1 t*]] \ @@ -942,7 +942,7 @@ test fCmd-9.11 {file rename: comprehensive: dir to new name and dir} -setup { file mkdir td2 file mkdir td3 if {!([testConstraint unix] || [testConstraint winVista])} { - testchmod 555 td2 + testchmod 0555 td2 } file rename td1 [file join td3 td3] file rename td2 [file join td3 td4] @@ -958,13 +958,13 @@ test fCmd-9.12 {file rename: comprehensive: target exists} -setup { cleanup } -constraints {notRoot testchmod notNetworkFilesystem} -body { file mkdir [file join td1 td2] [file join td2 td1] - testchmod 555 [file join td2 td1] + testchmod 0555 [file join td2 td1] file mkdir [file join td3 td4] [file join td4 td3] file rename -force td3 td4 list [file exists td3] [file exists [file join td4 td3 td4]] \ [catch {file rename td1 td2} msg] $msg } -cleanup { - testchmod 755 [file join td2 td1] + testchmod 0755 [file join td2 td1] } -result [subst {0 1 1 {error renaming "td1" to "[file join td2 td1]": file already exists}}] # Test can hit EEXIST or EBUSY, depending on underlying filesystem test fCmd-9.13 {file rename: comprehensive: can't overwrite target} -setup { @@ -1035,7 +1035,7 @@ test fCmd-10.2 {file copy: comprehensive: file to new name} -setup { } -constraints {notRoot testchmod} -body { createfile tf1 tf1 createfile tf2 tf2 - testchmod 444 tf2 + testchmod 0444 tf2 file copy tf1 tf3 file copy tf2 tf4 list [lsort [glob tf*]] [contents tf3] [contents tf4] [file writable tf3] [file writable tf4] @@ -1045,14 +1045,14 @@ test fCmd-10.3 {file copy: comprehensive: dir to new name} -setup { } -constraints {unix notRoot testchmod} -body { file mkdir [file join td1 tdx] file mkdir [file join td2 tdy] - testchmod 555 td2 + testchmod 0555 td2 file copy td1 td3 file copy td2 td4 list [lsort [glob td*]] [glob -directory td3 t*] \ [glob -directory td4 t*] [file writable td3] [file writable td4] } -cleanup { - testchmod 755 td2 - testchmod 755 td4 + testchmod 0755 td2 + testchmod 0755 td4 } -result [list {td1 td2 td3 td4} [file join td3 tdx] [file join td4 tdy] 1 0] test fCmd-10.3.1 {file copy: comprehensive: dir to new name} -setup { cleanup @@ -1060,14 +1060,14 @@ test fCmd-10.3.1 {file copy: comprehensive: dir to new name} -setup { # On Windows with ACLs, copying a directory is defined like this file mkdir [file join td1 tdx] file mkdir [file join td2 tdy] - testchmod 555 td2 + testchmod 0555 td2 file copy td1 td3 file copy td2 td4 list [lsort [glob td*]] [glob -directory td3 t*] \ [glob -directory td4 t*] [file writable td3] [file writable td4] } -cleanup { - testchmod 755 td2 - testchmod 755 td4 + testchmod 0755 td2 + testchmod 0755 td4 } -result [list {td1 td2 td3 td4} [file join td3 tdx] [file join td4 tdy] 1 1] test fCmd-10.4 {file copy: comprehensive: file to existing file} -setup { cleanup @@ -1082,10 +1082,10 @@ test fCmd-10.4 {file copy: comprehensive: file to existing file} -setup { createfile tfd2 createfile tfd3 createfile tfd4 - testchmod 444 tfs3 - testchmod 444 tfs4 - testchmod 444 tfd2 - testchmod 444 tfd4 + testchmod 0444 tfs3 + testchmod 0444 tfs4 + testchmod 0444 tfd2 + testchmod 0444 tfd4 set msg [list [catch {file copy tf1 tf2} msg] $msg] file copy -force tfs1 tfd1 file copy -force tfs2 tfd2 @@ -1106,10 +1106,10 @@ test fCmd-10.5 {file copy: comprehensive: dir to empty dir} -setup { file mkdir [file join tdd2 tds2] file mkdir [file join tdd3 tds3] file mkdir [file join tdd4 tds4] - testchmod 555 tds3 - testchmod 555 tds4 - testchmod 555 [file join tdd2 tds2] - testchmod 555 [file join tdd4 tds4] + testchmod 0555 tds3 + testchmod 0555 tds4 + testchmod 0555 [file join tdd2 tds2] + testchmod 0555 [file join tdd4 tds4] set a1 [list [catch {file copy td1 td2} msg] $msg] set a2 [list [catch {file copy -force tds1 tdd1} msg] $msg] set a3 [catch {file copy -force tds2 tdd2}] @@ -1124,7 +1124,7 @@ test fCmd-10.6 {file copy: comprehensive: dir to non-empty dir} -setup { file mkdir tds2 file mkdir [file join tdd1 tds1 xxx] file mkdir [file join tdd2 tds2 xxx] - testchmod 555 tds2 + testchmod 0555 tds2 set a1 [list [catch {file copy -force tds1 tdd1} msg] $msg] set a2 [list [catch {file copy -force tds2 tdd2} msg] $msg] list [lsort [glob td*]] $a1 $a2 [file writable tds1] [file writable tds2] @@ -1135,7 +1135,7 @@ test fCmd-10.7 {file rename: comprehensive: file to new name and dir} -setup { createfile tf1 createfile tf2 file mkdir td1 - testchmod 444 tf2 + testchmod 0444 tf2 file copy tf1 [file join td1 tf3] file copy tf2 [file join td1 tf4] list [lsort [glob tf*]] [lsort [glob -directory td1 t*]] \ @@ -1147,7 +1147,7 @@ test fCmd-10.8 {file rename: comprehensive: dir to new name and dir} -setup { file mkdir td1 file mkdir td2 file mkdir td3 - testchmod 555 td2 + testchmod 0555 td2 file copy td1 [file join td3 td3] file copy td2 [file join td3 td4] list [lsort [glob td*]] [lsort [glob -directory td3 t*]] \ @@ -1160,7 +1160,7 @@ test fCmd-10.8.1 {file rename: comprehensive: dir to new name and dir} -setup { file mkdir td1 file mkdir td2 file mkdir td3 - testchmod 555 td2 + testchmod 0555 td2 file copy td1 [file join td3 td3] file copy td2 [file join td3 td4] list [lsort [glob td*]] [lsort [glob -directory td3 t*]] \ diff --git a/tests/tcltest.test b/tests/tcltest.test index ce8d617..5894308 100644 --- a/tests/tcltest.test +++ b/tests/tcltest.test @@ -142,7 +142,7 @@ test tcltest-2.5a {tcltest -verbose 'pass skip body'} {unixOrPc} { } {0 1 1 1 1} test tcltest-2.6 {tcltest -verbose 't'} { - -constraints {unixOrPc} + -constraints {unixOrPc} -body { set result [slave msg test.tcl -verbose 't'] list $result $msg @@ -152,7 +152,7 @@ test tcltest-2.6 {tcltest -verbose 't'} { } test tcltest-2.6a {tcltest -verbose 'start'} { - -constraints {unixOrPc} + -constraints {unixOrPc} -body { set result [slave msg test.tcl -verbose start] list $result $msg @@ -169,7 +169,7 @@ test tcltest-2.7 {tcltest::verbose} { verbose foo set newVerbosity [verbose] verbose $oldVerbosity - list $currentVerbosity $newVerbosity + list $currentVerbosity $newVerbosity } -result {body {}} } @@ -217,7 +217,7 @@ test tcltest-3.5 {tcltest::match} { } -result {foo bar} } - + # -skip, [skip] test tcltest-4.1 {tcltest -skip 'a*'} {unixOrPc} { set result [slave msg test.tcl -skip a* -verbose 'ps'] @@ -299,8 +299,8 @@ test tcltest-5.3 {testConstraint - constraint empty (tcltest::safeFetch)} { # -result {{} tcltestFakeConstraint1 {tcltestFakeConstraint1 tcltestFakeConstraint2}} # -cleanup { # set ::tcltest::constraintsSpecified $constraintlist -# unset ::tcltest::testConstraints(tcltestFakeConstraint1) -# unset ::tcltest::testConstraints(tcltestFakeConstraint2) +# unset ::tcltest::testConstraints(tcltestFakeConstraint1) +# unset ::tcltest::testConstraints(tcltestFakeConstraint2) # } #} @@ -348,7 +348,7 @@ set printerror [makeFile { ::tcltest::PrintError "a really really long string containing a \ \"Path/that/is/really/long/and/contains/no/spaces\"" ::tcltest::PrintError "a really really long string containing a \ - \"Really/Long/Path/that/contains/no/spaces/and/is/longer/than/eighty/characters/to/see/what/happens\"" + \"Really/Long/Path/that/contains/no/spaces/and/is/longer/than/eighty/characters/to/see/what/happens\"" ::tcltest::PrintError "Problem renaming file: error renaming \"Z:/ws/tcl8.2/win32-ix86/tests/core\" to \"Z:/ws/tcl8.2/win32-ix86/tests/movecore-core\"" exit } printerror.tcl] @@ -367,7 +367,7 @@ test tcltest-6.2 {tcltest -outfile a.tmp} {unixOrPc unixExecs} { set result1 [catch {exec grep "a test" a.tmp}] set result2 [catch {exec grep "a really" a.tmp}] list [regexp "a test" $msg] [regexp "a really" $msg] \ - $result1 $result2 [file exists a.tmp] [file delete a.tmp] + $result1 $result2 [file exists a.tmp] [file delete a.tmp] } {0 1 0 1 1 {}} test tcltest-6.3 {tcltest -errfile a.tmp} {unixOrPc unixExecs} { slave msg $printerror -errfile a.tmp @@ -413,7 +413,7 @@ test tcltest-6.6 {tcltest::errorFile (implicit errorChannel)} { set f2 [errorFile $ef] set f3 [errorChannel] set f4 [errorFile] - subst {$f0;$f1;$f2;$f3;$f4} + subst {$f0;$f1;$f2;$f3;$f4} } -result {stderr;stderr;.*efile;file[0-9a-f]+;.*efile} -match regexp @@ -449,7 +449,7 @@ test tcltest-6.8 {tcltest::outputFile (implicit outputFile)} { set f2 [outputFile $ef] set f3 [outputChannel] set f4 [outputFile] - subst {$f0;$f1;$f2;$f3;$f4} + subst {$f0;$f1;$f2;$f3;$f4} } -result {stdout;stdout;.*efile;file[0-9a-f]+;.*efile} -match regexp @@ -550,7 +550,7 @@ switch -- $::tcl_platform(platform) { } default { catch {file attributes $notWriteableDir -readonly 1} - catch {testchmod 000 $notWriteableDir} + catch {testchmod 0 $notWriteableDir} } } test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} { @@ -717,7 +717,7 @@ switch -- $::tcl_platform(platform) { file attributes $notWriteableDir -permissions 777 } default { - catch {testchmod 777 $notWriteableDir} + catch {testchmod 0777 $notWriteableDir} catch {file attributes $notWriteableDir -readonly 0} } } @@ -758,7 +758,7 @@ test tcltest-9.3 {matchFiles} { set new [matchFiles] matchFiles $old list $current $new - } + } -result {foo bar} } @@ -771,7 +771,7 @@ test tcltest-9.4 {skipFiles} { set new [skipFiles] skipFiles $old list $current $new - } + } -result {foo bar} } @@ -1146,7 +1146,7 @@ test tcltest-19.1 {TCLTEST_OPTIONS default} -setup { interp delete slave2 interp delete slave1 if {$oldoptions eq "none"} { - unset ::env(TCLTEST_OPTIONS) + unset ::env(TCLTEST_OPTIONS) } else { set ::env(TCLTEST_OPTIONS) $oldoptions } @@ -1260,7 +1260,7 @@ test tcltest-21.6 {test command - setup occurs before cleanup & before script} { } set foo 1 set expected 2 - } + } -body { incr foo set foo @@ -1424,7 +1424,7 @@ test tcltest-23.1 {makeFile} { } -cleanup { file delete -force $mfdir \ - [file join [temporaryDirectory] t1.tmp] + [file join [temporaryDirectory] t1.tmp] } -result {1 1} } @@ -1447,7 +1447,7 @@ test tcltest-23.2 {removeFile} { } -cleanup { file delete -force $mfdir \ - [file join [temporaryDirectory] t1.tmp] + [file join [temporaryDirectory] t1.tmp] } -result {0 0} } diff --git a/tests/unixFCmd.test b/tests/unixFCmd.test index e4613ed..3755fed 100644 --- a/tests/unixFCmd.test +++ b/tests/unixFCmd.test @@ -59,7 +59,7 @@ if {[testConstraint unix]} { } proc openup {path} { - testchmod 777 $path + testchmod 0777 $path if {[file isdirectory $path]} { catch { foreach p [glob -directory $path *] { diff --git a/tests/winFCmd.test b/tests/winFCmd.test index 28257c6..14d3d07 100644 --- a/tests/winFCmd.test +++ b/tests/winFCmd.test @@ -335,12 +335,12 @@ test winFCmd-1.32 {TclpRenameFile: TclpRemoveDirectory succeeds} -setup { test winFCmd-1.33 {TclpRenameFile: After removing dst dir, MoveFile fails} \ -constraints {win exdev testfile testchmod} -body { file mkdir d:/td1 - testchmod 000 d:/td1 + testchmod 0 d:/td1 file mkdir c:/tf1 catch {testfile mv c:/tf1 d:/td1} msg list $msg [file writable d:/td1] } -cleanup { - catch {testchmod 666 d:/td1} + catch {testchmod 0666 d:/td1} file delete d:/td1 file delete -force c:/tf1 } -result {EXDEV 0} @@ -489,11 +489,11 @@ test winFCmd-2.12 {TclpCopyFile: CopyFile succeeds} -setup { cleanup } -constraints {win testfile} -body { createfile tf1 tf1 - testchmod 000 tf1 + testchmod 0 tf1 testfile cp tf1 tf2 list [contents tf2] [file writable tf2] } -cleanup { - catch {testchmod 666 tf1} + catch {testchmod 0666 tf1} cleanup } -result {tf1 0} test winFCmd-2.13 {TclpCopyFile: CopyFile fails} -setup { @@ -535,11 +535,11 @@ test winFCmd-2.17 {TclpCopyFile: dst is readonly} -setup { } -constraints {win testfile testchmod} -body { createfile tf1 tf1 createfile tf2 tf2 - testchmod 000 tf2 + testchmod 0 tf2 testfile cp tf1 tf2 list [file writable tf2] [contents tf2] } -cleanup { - catch {testchmod 666 tf2} + catch {testchmod 0666 tf2} cleanup } -result {1 tf1} @@ -605,7 +605,7 @@ test winFCmd-3.10 {TclpDeleteFile: path is readonly} -setup { cleanup } -constraints {win testfile testchmod} -body { createfile tf1 - testchmod 000 tf1 + testchmod 0 tf1 testfile rm tf1 file exists tf1 } -result {0} @@ -613,11 +613,11 @@ test winFCmd-3.11 {TclpDeleteFile: still can't remove path} -setup { cleanup } -constraints {win testfile testchmod} -body { set fd [open tf1 w] - testchmod 000 tf1 + testchmod 0 tf1 testfile rm tf1 } -cleanup { close $fd - catch {testchmod 666 tf1} + catch {testchmod 0666 tf1} cleanup } -returnCodes error -result EACCES @@ -658,11 +658,11 @@ test winFCmd-6.1 {TclpRemoveDirectory: errno: EACCES} -setup { cleanup } -constraints {winVista testfile testchmod} -body { file mkdir td1 - testchmod 000 td1 + testchmod 0 td1 testfile rmdir td1 file exists td1 } -returnCodes error -cleanup { - catch {testchmod 666 td1} + catch {testchmod 0666 td1} cleanup } -result {td1 EACCES} # This next test has a very hokey way of matching... @@ -712,11 +712,11 @@ test winFCmd-6.9 {TclpRemoveDirectory: errno == EACCES} -setup { cleanup } -constraints {winVista testfile testchmod} -body { file mkdir td1 - testchmod 000 td1 + testchmod 0 td1 testfile rmdir td1 file exists td1 } -returnCodes error -cleanup { - catch {testchmod 666 td1} + catch {testchmod 0666 td1} cleanup } -result {td1 EACCES} test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} -setup { @@ -730,11 +730,11 @@ test winFCmd-6.13 {TclpRemoveDirectory: write-protected} -setup { cleanup } -constraints {winVista testfile testchmod} -body { file mkdir td1 - testchmod 000 td1 + testchmod 0 td1 testfile rmdir td1 file exists td1 } -cleanup { - catch {testchmod 666 td1} + catch {testchmod 0666 td1} cleanup } -returnCodes error -result {td1 EACCES} # This next test has a very hokey way of matching... @@ -830,11 +830,11 @@ test winFCmd-7.11 {TraverseWinTree: call TraversalCopy: DOTREE_PRED} -setup { } -constraints {win testfile testchmod} -body { file mkdir td1 createfile td1/tf1 tf1 - testchmod 000 td1 + testchmod 0 td1 testfile cpdir td1 td2 list [file exists td2] [file writable td2] } -cleanup { - catch {testchmod 666 td1} + catch {testchmod 0666 td1} cleanup } -result {1 1} test winFCmd-7.12 {TraverseWinTree: call TraversalDelete: DOTREE_PRED} -setup { @@ -901,11 +901,11 @@ test winFCmd-7.19 {TraverseWinTree: call TraversalCopy: DOTREE_POSTD} -setup { } -constraints {win testfile testchmod} -body { file mkdir td1 createfile td1/tf1 tf1 - testchmod 000 td1 + testchmod 0 td1 testfile cpdir td1 td2 list [file exists td2] [file writable td2] } -cleanup { - catch {testchmod 666 td1} + catch {testchmod 0666 td1} cleanup } -result {1 1} test winFCmd-7.20 {TraverseWinTree: call TraversalDelete: DOTREE_POSTD} -setup { @@ -932,11 +932,11 @@ test winFCmd-8.2 {TraversalCopy: DOTREE_PRED} -setup { cleanup } -constraints {win testfile testchmod} -body { file mkdir td1/td2 - testchmod 000 td1 + testchmod 0 td1 testfile cpdir td1 td2 list [file writable td1] [file writable td1/td2] } -cleanup { - catch {testchmod 666 td1} + catch {testchmod 0666 td1} cleanup } -result {0 1} test winFCmd-8.3 {TraversalCopy: DOTREE_POSTD} -setup { @@ -959,11 +959,11 @@ test winFCmd-9.3 {TraversalDelete: DOTREE_PRED} -setup { cleanup } -constraints {winVista testfile testchmod} -body { file mkdir td1/td2 - testchmod 000 td1 + testchmod 0 td1 testfile rmdir -force td1 file exists td1 } -cleanup { - catch {testchmod 666 td1} + catch {testchmod 0666 td1} cleanup } -returnCodes error -result {td1 EACCES} test winFCmd-9.4 {TraversalDelete: DOTREE_POSTD} -setup { -- cgit v0.12 From 88540658b1ee3783ec66a39d7ea77d8fb3e5cd3f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 17 Jul 2014 15:15:28 +0000 Subject: Convert TesteventloopCmd and TestchmodCmd to Tcl_Obj-API form. --- unix/tclUnixTest.c | 24 ++++++++++-------------- unix/tclXtTest.c | 19 +++++++++---------- win/tclWinTest.c | 47 +++++++++++++++++++++-------------------------- 3 files changed, 40 insertions(+), 50 deletions(-) diff --git a/unix/tclUnixTest.c b/unix/tclUnixTest.c index 4b0f369..c5ac52a 100644 --- a/unix/tclUnixTest.c +++ b/unix/tclUnixTest.c @@ -63,7 +63,7 @@ static const char *gotsig = "0"; */ static Tcl_CmdProc TestalarmCmd; -static Tcl_CmdProc TestchmodCmd; +static Tcl_ObjCmdProc TestchmodCmd; static Tcl_CmdProc TestfilehandlerCmd; static Tcl_CmdProc TestfilewaitCmd; static Tcl_CmdProc TestfindexecutableCmd; @@ -96,7 +96,7 @@ int TclplatformtestInit( Tcl_Interp *interp) /* Interpreter to add commands to. */ { - Tcl_CreateCommand(interp, "testchmod", TestchmodCmd, + Tcl_CreateObjCommand(interp, "testchmod", TestchmodCmd, NULL, NULL); Tcl_CreateCommand(interp, "testfilehandler", TestfilehandlerCmd, NULL, NULL); @@ -740,29 +740,25 @@ static int TestchmodCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - const char **argv) /* Argument strings. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const *objv) /* Argument strings. */ { int i, mode; - char *rest; - if (argc < 2) { - usage: - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " mode file ?file ...?", NULL); + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "mode file ?file ...?"); return TCL_ERROR; } - mode = (int) strtol(argv[1], &rest, 8); - if ((rest == argv[1]) || (*rest != '\0')) { - goto usage; + if (Tcl_GetIntFromObj(interp, objv[1], &mode) != TCL_OK) { + return TCL_ERROR; } - for (i = 2; i < argc; i++) { + for (i = 2; i < objc; i++) { Tcl_DString buffer; const char *translated; - translated = Tcl_TranslateFileName(interp, argv[i], &buffer); + translated = Tcl_TranslateFileName(interp, Tcl_GetString(objv[i]), &buffer); if (translated == NULL) { return TCL_ERROR; } diff --git a/unix/tclXtTest.c b/unix/tclXtTest.c index fcb0773..f7c2652 100644 --- a/unix/tclXtTest.c +++ b/unix/tclXtTest.c @@ -15,7 +15,7 @@ #include #include "tcl.h" -static Tcl_CmdProc TesteventloopCmd; +static Tcl_ObjCmdProc TesteventloopCmd; extern DLLEXPORT Tcl_PackageInitProc Tclxttest_Init; /* @@ -53,7 +53,7 @@ Tclxttest_Init( } XtToolkitInitialize(); InitNotifier(); - Tcl_CreateCommand(interp, "testeventloop", TesteventloopCmd, + Tcl_CreateObjCommand(interp, "testeventloop", TesteventloopCmd, NULL, NULL); return TCL_OK; } @@ -80,21 +80,20 @@ static int TesteventloopCmd( ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - const char **argv) /* Argument strings. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { static int *framePtr = NULL;/* Pointer to integer on stack frame of * innermost invocation of the "wait" * subcommand. */ - if (argc < 2) { - Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], - " option ... \"", NULL); + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "option ..."); return TCL_ERROR; } - if (strcmp(argv[1], "done") == 0) { + if (strcmp(Tcl_GetString(objv[1]), "done") == 0) { *framePtr = 1; - } else if (strcmp(argv[1], "wait") == 0) { + } else if (strcmp(Tcl_GetString(objv[1]), "wait") == 0) { int *oldFramePtr; int done; int oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL); @@ -118,7 +117,7 @@ TesteventloopCmd( (void) Tcl_SetServiceMode(oldMode); framePtr = oldFramePtr; } else { - Tcl_AppendResult(interp, "bad option \"", argv[1], + Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[1]), "\": must be done or wait", NULL); return TCL_ERROR; } diff --git a/win/tclWinTest.c b/win/tclWinTest.c index 6027e32..b3ad626 100644 --- a/win/tclWinTest.c +++ b/win/tclWinTest.c @@ -32,8 +32,8 @@ * Forward declarations of functions defined later in this file: */ -static int TesteventloopCmd(ClientData dummy, Tcl_Interp *interp, - int argc, const char **argv); +static int TesteventloopCmd(ClientData dummy, Tcl_Interp* interp, + int objc, Tcl_Obj *const objv[]); static int TestvolumetypeCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -43,8 +43,8 @@ static int TestwinsleepCmd(ClientData dummy, Tcl_Interp* interp, int objc, Tcl_Obj *const objv[]); static Tcl_ObjCmdProc TestExceptionCmd; static int TestplatformChmod(const char *nativePath, int pmode); -static int TestchmodCmd(ClientData dummy, - Tcl_Interp *interp, int argc, const char **argv); +static int TestchmodCmd(ClientData dummy, Tcl_Interp* interp, + int objc, Tcl_Obj *const objv[]); /* *---------------------------------------------------------------------- @@ -71,8 +71,8 @@ TclplatformtestInit( * Add commands for platform specific tests for Windows here. */ - Tcl_CreateCommand(interp, "testchmod", TestchmodCmd, NULL, NULL); - Tcl_CreateCommand(interp, "testeventloop", TesteventloopCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testchmod", TestchmodCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testeventloop", TesteventloopCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testvolumetype", TestvolumetypeCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testwinclock", TestwinclockCmd, NULL, NULL); @@ -103,21 +103,20 @@ static int TesteventloopCmd( ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - const char **argv) /* Argument strings. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { static int *framePtr = NULL;/* Pointer to integer on stack frame of * innermost invocation of the "wait" * subcommand. */ - if (argc < 2) { - Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], - " option ... \"", NULL); + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "option ..."); return TCL_ERROR; } - if (strcmp(argv[1], "done") == 0) { + if (strcmp(Tcl_GetString(objv[1]), "done") == 0) { *framePtr = 1; - } else if (strcmp(argv[1], "wait") == 0) { + } else if (strcmp(Tcl_GetString(objv[1]), "wait") == 0) { int *oldFramePtr, done; int oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL); @@ -152,7 +151,7 @@ TesteventloopCmd( (void) Tcl_SetServiceMode(oldMode); framePtr = oldFramePtr; } else { - Tcl_AppendResult(interp, "bad option \"", argv[1], + Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[1]), "\": must be done or wait", NULL); return TCL_ERROR; } @@ -623,29 +622,25 @@ static int TestchmodCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - const char **argv) /* Argument strings. */ + int objc, /* Parameter count */ + Tcl_Obj *const * objv) /* Parameter vector */ { int i, mode; - char *rest; - if (argc < 2) { - usage: - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " mode file ?file ...?", NULL); + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "mode file ?file ...?"); return TCL_ERROR; } - mode = (int) strtol(argv[1], &rest, 8); - if ((rest == argv[1]) || (*rest != '\0')) { - goto usage; + if (Tcl_GetIntFromObj(interp, objv[1], &mode) != TCL_OK) { + return TCL_ERROR; } - for (i = 2; i < argc; i++) { + for (i = 2; i < objc; i++) { Tcl_DString buffer; const char *translated; - translated = Tcl_TranslateFileName(interp, argv[i], &buffer); + translated = Tcl_TranslateFileName(interp, Tcl_GetString(objv[i]), &buffer); if (translated == NULL) { return TCL_ERROR; } -- cgit v0.12 From db085cadf4603de2c124a2b2afc4b020d28d21c7 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 17 Jul 2014 15:48:59 +0000 Subject: Revised fix for memleak in [info frame]. Still pretty ugly, but not more so than a lot of TIP 280 machinery. --- generic/tclCmdIL.c | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index a26d6cc..d723e4b 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -1287,6 +1287,7 @@ TclInfoFrame( "eval", "eval", "eval", "precompiled", "source", "proc" }; Proc *procPtr = framePtr->framePtr ? framePtr->framePtr->procPtr : NULL; + int needsFree = -1; /* * Pull the information and construct the dictionary to return, as list. @@ -1360,6 +1361,9 @@ TclInfoFrame( } ADD_PAIR("cmd", TclGetSourceFromFrame(fPtr, 0, NULL)); + if (fPtr->cmdObj && framePtr->cmdObj == NULL) { + needsFree = lc - 1; + } TclStackFree(interp, fPtr); break; } @@ -1447,7 +1451,11 @@ TclInfoFrame( } } - return Tcl_NewListObj(lc, lv); + tmpObj = Tcl_NewListObj(lc, lv); + if (needsFree >= 0) { + Tcl_DecrRefCount(lv[needsFree]); + } + return tmpObj; } /* -- cgit v0.12 From 0cb480df70afc69c2a1637894dddd3f0b4e6d351 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 17 Jul 2014 18:43:55 +0000 Subject: Finally, use correct octal notation which works in Tcl 9 as well. --- tests/cmdAH.test | 10 +++---- tests/fCmd.test | 82 ++++++++++++++++++++++++++--------------------------- tests/tcltest.test | 2 +- tests/unixFCmd.test | 2 +- tests/winFCmd.test | 22 +++++++------- 5 files changed, 59 insertions(+), 59 deletions(-) diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 04a86fa..64cfeba 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -829,13 +829,13 @@ test cmdAH-16.1 {Tcl_FileObjCmd: readable} { } test cmdAH-16.2 {Tcl_FileObjCmd: readable} { -constraints testchmod - -setup {testchmod 0444 $gorpfile} + -setup {testchmod 0o444 $gorpfile} -body {file readable $gorpfile} -result 1 } test cmdAH-16.3 {Tcl_FileObjCmd: readable} { -constraints {unix notRoot testchmod} - -setup {testchmod 0333 $gorpfile} + -setup {testchmod 0o333 $gorpfile} -body {file readable $gorpfile} -result 0 } @@ -848,13 +848,13 @@ test cmdAH-17.1 {Tcl_FileObjCmd: writable} { } test cmdAH-17.2 {Tcl_FileObjCmd: writable} { -constraints {notRoot testchmod} - -setup {testchmod 0555 $gorpfile} + -setup {testchmod 0o555 $gorpfile} -body {file writable $gorpfile} -result 0 } test cmdAH-17.3 {Tcl_FileObjCmd: writable} { -constraints testchmod - -setup {testchmod 0222 $gorpfile} + -setup {testchmod 0o222 $gorpfile} -body {file writable $gorpfile} -result 1 } @@ -873,7 +873,7 @@ test cmdAH-18.2 {Tcl_FileObjCmd: executable} {notRoot} { test cmdAH-18.3 {Tcl_FileObjCmd: executable} {unix testchmod} { # Only on unix will setting the execute bit on a regular file cause that # file to be executable. - testchmod 0775 $gorpfile + testchmod 0o775 $gorpfile file exe $gorpfile } 1 test cmdAH-18.5 {Tcl_FileObjCmd: executable} -constraints {win} -body { diff --git a/tests/fCmd.test b/tests/fCmd.test index c479e35..c8264b2 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.test @@ -128,7 +128,7 @@ proc checkcontent {file matchString} { } proc openup {path} { - testchmod 0777 $path + testchmod 0o777 $path if {[file isdirectory $path]} { catch { foreach p [glob -directory $path *] { @@ -365,7 +365,7 @@ test fCmd-4.11 {TclFileMakeDirsCmd: doesn't exist: errno != ENOENT} -setup { testchmod 0 td1/td2 file mkdir td1/td2/td3/td4 } -cleanup { - testchmod 0755 td1/td2 + testchmod 0o755 td1/td2 cleanup } -result {can't create directory "td1/td2/td3": permission denied} test fCmd-4.13 {TclFileMakeDirsCmd: doesn't exist: errno == ENOENT} -setup { @@ -509,7 +509,7 @@ test fCmd-6.6 {CopyRenameOneFile: errno != ENOENT} -setup { createfile tf1 file rename tf1 td1 } -returnCodes error -cleanup { - testchmod 0755 td1 + testchmod 0o755 td1 } -result {error renaming "tf1" to "td1/tf1": permission denied} test fCmd-6.9 {CopyRenameOneFile: errno == ENOENT} -setup { cleanup @@ -785,7 +785,7 @@ test fCmd-9.3 {file rename: comprehensive: file to new name} -setup { } -constraints {notRoot testchmod} -body { createfile tf1 createfile tf2 - testchmod 0444 tf2 + testchmod 0o444 tf2 file rename tf1 tf3 file rename tf2 tf4 list [lsort [glob tf*]] [file writable tf3] [file writable tf4] @@ -794,7 +794,7 @@ test fCmd-9.4.a {file rename: comprehensive: dir to new name} -setup { cleanup } -constraints {win win2000orXP testchmod} -body { file mkdir td1 td2 - testchmod 0555 td2 + testchmod 0o555 td2 file rename td1 td3 file rename td2 td4 list [lsort [glob td*]] [file writable td3] [file writable td4] @@ -805,7 +805,7 @@ test fCmd-9.4.b {file rename: comprehensive: dir to new name} -setup { cleanup } -constraints {unix notRoot testchmod notDarwin9} -body { file mkdir td1 td2 - testchmod 0555 td2 + testchmod 0o555 td2 file rename td1 td3 file rename td2 td4 list [lsort [glob td*]] [file writable td3] [file writable td4] @@ -817,7 +817,7 @@ test fCmd-9.5 {file rename: comprehensive: file to self} -setup { } -constraints {notRoot testchmod} -body { createfile tf1 tf1 createfile tf2 tf2 - testchmod 0444 tf2 + testchmod 0o444 tf2 file rename -force tf1 tf1 file rename -force tf2 tf2 list [contents tf1] [contents tf2] [file writable tf1] [file writable tf2] @@ -827,7 +827,7 @@ test fCmd-9.6.a {file rename: comprehensive: dir to self} -setup { } -constraints {win win2000orXP testchmod} -body { file mkdir td1 file mkdir td2 - testchmod 0555 td2 + testchmod 0o555 td2 file rename -force td1 . file rename -force td2 . list [lsort [glob td*]] [file writable td1] [file writable td2] @@ -837,7 +837,7 @@ test fCmd-9.6.b {file rename: comprehensive: dir to self} -setup { } -constraints {unix notRoot testchmod} -body { file mkdir td1 file mkdir td2 - testchmod 0555 td2 + testchmod 0o555 td2 file rename -force td1 . file rename -force td2 . list [lsort [glob td*]] [file writable td1] [file writable td2] @@ -855,10 +855,10 @@ test fCmd-9.7 {file rename: comprehensive: file to existing file} -setup { createfile tfd2 createfile tfd3 createfile tfd4 - testchmod 0444 tfs3 - testchmod 0444 tfs4 - testchmod 0444 tfd2 - testchmod 0444 tfd4 + testchmod 0o444 tfs3 + testchmod 0o444 tfs4 + testchmod 0o444 tfd2 + testchmod 0o444 tfd4 set msg [list [catch {file rename tf1 tf2} msg] $msg] file rename -force tfs1 tfd1 file rename -force tfs2 tfd2 @@ -882,11 +882,11 @@ test fCmd-9.8 {file rename: comprehensive: dir to empty dir} -setup { file mkdir [file join tdd3 tds3] file mkdir [file join tdd4 tds4] if {![testConstraint unix]} { - testchmod 0555 tds3 - testchmod 0555 tds4 + testchmod 0o555 tds3 + testchmod 0o555 tds4 } - testchmod 0555 [file join tdd2 tds2] - testchmod 0555 [file join tdd4 tds4] + testchmod 0o555 [file join tdd2 tds2] + testchmod 0o555 [file join tdd4 tds4] set msg [list [catch {file rename td1 td2} msg] $msg] file rename -force tds1 tdd1 file rename -force tds2 tdd2 @@ -911,7 +911,7 @@ test fCmd-9.9 {file rename: comprehensive: dir to non-empty dir} -setup { file mkdir [file join tdd1 tds1 xxx] file mkdir [file join tdd2 tds2 xxx] if {!([testConstraint unix] || [testConstraint winVista])} { - testchmod 0555 tds2 + testchmod 0o555 tds2 } set a1 [list [catch {file rename -force tds1 tdd1} msg] $msg] set a2 [list [catch {file rename -force tds2 tdd2} msg] $msg] @@ -929,7 +929,7 @@ test fCmd-9.10 {file rename: comprehensive: file to new name and dir} -setup { createfile tf1 createfile tf2 file mkdir td1 - testchmod 0444 tf2 + testchmod 0o444 tf2 file rename tf1 [file join td1 tf3] file rename tf2 [file join td1 tf4] list [catch {glob tf*}] [lsort [glob -directory td1 t*]] \ @@ -942,7 +942,7 @@ test fCmd-9.11 {file rename: comprehensive: dir to new name and dir} -setup { file mkdir td2 file mkdir td3 if {!([testConstraint unix] || [testConstraint winVista])} { - testchmod 0555 td2 + testchmod 0o555 td2 } file rename td1 [file join td3 td3] file rename td2 [file join td3 td4] @@ -958,13 +958,13 @@ test fCmd-9.12 {file rename: comprehensive: target exists} -setup { cleanup } -constraints {notRoot testchmod notNetworkFilesystem} -body { file mkdir [file join td1 td2] [file join td2 td1] - testchmod 0555 [file join td2 td1] + testchmod 0o555 [file join td2 td1] file mkdir [file join td3 td4] [file join td4 td3] file rename -force td3 td4 list [file exists td3] [file exists [file join td4 td3 td4]] \ [catch {file rename td1 td2} msg] $msg } -cleanup { - testchmod 0755 [file join td2 td1] + testchmod 0o755 [file join td2 td1] } -result [subst {0 1 1 {error renaming "td1" to "[file join td2 td1]": file already exists}}] # Test can hit EEXIST or EBUSY, depending on underlying filesystem test fCmd-9.13 {file rename: comprehensive: can't overwrite target} -setup { @@ -1035,7 +1035,7 @@ test fCmd-10.2 {file copy: comprehensive: file to new name} -setup { } -constraints {notRoot testchmod} -body { createfile tf1 tf1 createfile tf2 tf2 - testchmod 0444 tf2 + testchmod 0o444 tf2 file copy tf1 tf3 file copy tf2 tf4 list [lsort [glob tf*]] [contents tf3] [contents tf4] [file writable tf3] [file writable tf4] @@ -1045,14 +1045,14 @@ test fCmd-10.3 {file copy: comprehensive: dir to new name} -setup { } -constraints {unix notRoot testchmod} -body { file mkdir [file join td1 tdx] file mkdir [file join td2 tdy] - testchmod 0555 td2 + testchmod 0o555 td2 file copy td1 td3 file copy td2 td4 list [lsort [glob td*]] [glob -directory td3 t*] \ [glob -directory td4 t*] [file writable td3] [file writable td4] } -cleanup { - testchmod 0755 td2 - testchmod 0755 td4 + testchmod 0o755 td2 + testchmod 0o755 td4 } -result [list {td1 td2 td3 td4} [file join td3 tdx] [file join td4 tdy] 1 0] test fCmd-10.3.1 {file copy: comprehensive: dir to new name} -setup { cleanup @@ -1060,14 +1060,14 @@ test fCmd-10.3.1 {file copy: comprehensive: dir to new name} -setup { # On Windows with ACLs, copying a directory is defined like this file mkdir [file join td1 tdx] file mkdir [file join td2 tdy] - testchmod 0555 td2 + testchmod 0o555 td2 file copy td1 td3 file copy td2 td4 list [lsort [glob td*]] [glob -directory td3 t*] \ [glob -directory td4 t*] [file writable td3] [file writable td4] } -cleanup { - testchmod 0755 td2 - testchmod 0755 td4 + testchmod 0o755 td2 + testchmod 0o755 td4 } -result [list {td1 td2 td3 td4} [file join td3 tdx] [file join td4 tdy] 1 1] test fCmd-10.4 {file copy: comprehensive: file to existing file} -setup { cleanup @@ -1082,10 +1082,10 @@ test fCmd-10.4 {file copy: comprehensive: file to existing file} -setup { createfile tfd2 createfile tfd3 createfile tfd4 - testchmod 0444 tfs3 - testchmod 0444 tfs4 - testchmod 0444 tfd2 - testchmod 0444 tfd4 + testchmod 0o444 tfs3 + testchmod 0o444 tfs4 + testchmod 0o444 tfd2 + testchmod 0o444 tfd4 set msg [list [catch {file copy tf1 tf2} msg] $msg] file copy -force tfs1 tfd1 file copy -force tfs2 tfd2 @@ -1106,10 +1106,10 @@ test fCmd-10.5 {file copy: comprehensive: dir to empty dir} -setup { file mkdir [file join tdd2 tds2] file mkdir [file join tdd3 tds3] file mkdir [file join tdd4 tds4] - testchmod 0555 tds3 - testchmod 0555 tds4 - testchmod 0555 [file join tdd2 tds2] - testchmod 0555 [file join tdd4 tds4] + testchmod 0o555 tds3 + testchmod 0o555 tds4 + testchmod 0o555 [file join tdd2 tds2] + testchmod 0o555 [file join tdd4 tds4] set a1 [list [catch {file copy td1 td2} msg] $msg] set a2 [list [catch {file copy -force tds1 tdd1} msg] $msg] set a3 [catch {file copy -force tds2 tdd2}] @@ -1124,7 +1124,7 @@ test fCmd-10.6 {file copy: comprehensive: dir to non-empty dir} -setup { file mkdir tds2 file mkdir [file join tdd1 tds1 xxx] file mkdir [file join tdd2 tds2 xxx] - testchmod 0555 tds2 + testchmod 0o555 tds2 set a1 [list [catch {file copy -force tds1 tdd1} msg] $msg] set a2 [list [catch {file copy -force tds2 tdd2} msg] $msg] list [lsort [glob td*]] $a1 $a2 [file writable tds1] [file writable tds2] @@ -1135,7 +1135,7 @@ test fCmd-10.7 {file rename: comprehensive: file to new name and dir} -setup { createfile tf1 createfile tf2 file mkdir td1 - testchmod 0444 tf2 + testchmod 0o444 tf2 file copy tf1 [file join td1 tf3] file copy tf2 [file join td1 tf4] list [lsort [glob tf*]] [lsort [glob -directory td1 t*]] \ @@ -1147,7 +1147,7 @@ test fCmd-10.8 {file rename: comprehensive: dir to new name and dir} -setup { file mkdir td1 file mkdir td2 file mkdir td3 - testchmod 0555 td2 + testchmod 0o555 td2 file copy td1 [file join td3 td3] file copy td2 [file join td3 td4] list [lsort [glob td*]] [lsort [glob -directory td3 t*]] \ @@ -1160,7 +1160,7 @@ test fCmd-10.8.1 {file rename: comprehensive: dir to new name and dir} -setup { file mkdir td1 file mkdir td2 file mkdir td3 - testchmod 0555 td2 + testchmod 0o555 td2 file copy td1 [file join td3 td3] file copy td2 [file join td3 td4] list [lsort [glob td*]] [lsort [glob -directory td3 t*]] \ diff --git a/tests/tcltest.test b/tests/tcltest.test index 5894308..e66678b 100644 --- a/tests/tcltest.test +++ b/tests/tcltest.test @@ -717,7 +717,7 @@ switch -- $::tcl_platform(platform) { file attributes $notWriteableDir -permissions 777 } default { - catch {testchmod 0777 $notWriteableDir} + catch {testchmod 0o777 $notWriteableDir} catch {file attributes $notWriteableDir -readonly 0} } } diff --git a/tests/unixFCmd.test b/tests/unixFCmd.test index 3755fed..2d227fe 100644 --- a/tests/unixFCmd.test +++ b/tests/unixFCmd.test @@ -59,7 +59,7 @@ if {[testConstraint unix]} { } proc openup {path} { - testchmod 0777 $path + testchmod 0o777 $path if {[file isdirectory $path]} { catch { foreach p [glob -directory $path *] { diff --git a/tests/winFCmd.test b/tests/winFCmd.test index 14d3d07..ab675d7 100644 --- a/tests/winFCmd.test +++ b/tests/winFCmd.test @@ -340,7 +340,7 @@ test winFCmd-1.33 {TclpRenameFile: After removing dst dir, MoveFile fails} \ catch {testfile mv c:/tf1 d:/td1} msg list $msg [file writable d:/td1] } -cleanup { - catch {testchmod 0666 d:/td1} + catch {testchmod 0o666 d:/td1} file delete d:/td1 file delete -force c:/tf1 } -result {EXDEV 0} @@ -493,7 +493,7 @@ test winFCmd-2.12 {TclpCopyFile: CopyFile succeeds} -setup { testfile cp tf1 tf2 list [contents tf2] [file writable tf2] } -cleanup { - catch {testchmod 0666 tf1} + catch {testchmod 0o666 tf1} cleanup } -result {tf1 0} test winFCmd-2.13 {TclpCopyFile: CopyFile fails} -setup { @@ -539,7 +539,7 @@ test winFCmd-2.17 {TclpCopyFile: dst is readonly} -setup { testfile cp tf1 tf2 list [file writable tf2] [contents tf2] } -cleanup { - catch {testchmod 0666 tf2} + catch {testchmod 0o666 tf2} cleanup } -result {1 tf1} @@ -617,7 +617,7 @@ test winFCmd-3.11 {TclpDeleteFile: still can't remove path} -setup { testfile rm tf1 } -cleanup { close $fd - catch {testchmod 0666 tf1} + catch {testchmod 0o666 tf1} cleanup } -returnCodes error -result EACCES @@ -662,7 +662,7 @@ test winFCmd-6.1 {TclpRemoveDirectory: errno: EACCES} -setup { testfile rmdir td1 file exists td1 } -returnCodes error -cleanup { - catch {testchmod 0666 td1} + catch {testchmod 0o666 td1} cleanup } -result {td1 EACCES} # This next test has a very hokey way of matching... @@ -716,7 +716,7 @@ test winFCmd-6.9 {TclpRemoveDirectory: errno == EACCES} -setup { testfile rmdir td1 file exists td1 } -returnCodes error -cleanup { - catch {testchmod 0666 td1} + catch {testchmod 0o666 td1} cleanup } -result {td1 EACCES} test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} -setup { @@ -734,7 +734,7 @@ test winFCmd-6.13 {TclpRemoveDirectory: write-protected} -setup { testfile rmdir td1 file exists td1 } -cleanup { - catch {testchmod 0666 td1} + catch {testchmod 0o666 td1} cleanup } -returnCodes error -result {td1 EACCES} # This next test has a very hokey way of matching... @@ -834,7 +834,7 @@ test winFCmd-7.11 {TraverseWinTree: call TraversalCopy: DOTREE_PRED} -setup { testfile cpdir td1 td2 list [file exists td2] [file writable td2] } -cleanup { - catch {testchmod 0666 td1} + catch {testchmod 0o666 td1} cleanup } -result {1 1} test winFCmd-7.12 {TraverseWinTree: call TraversalDelete: DOTREE_PRED} -setup { @@ -905,7 +905,7 @@ test winFCmd-7.19 {TraverseWinTree: call TraversalCopy: DOTREE_POSTD} -setup { testfile cpdir td1 td2 list [file exists td2] [file writable td2] } -cleanup { - catch {testchmod 0666 td1} + catch {testchmod 0o666 td1} cleanup } -result {1 1} test winFCmd-7.20 {TraverseWinTree: call TraversalDelete: DOTREE_POSTD} -setup { @@ -936,7 +936,7 @@ test winFCmd-8.2 {TraversalCopy: DOTREE_PRED} -setup { testfile cpdir td1 td2 list [file writable td1] [file writable td1/td2] } -cleanup { - catch {testchmod 0666 td1} + catch {testchmod 0o666 td1} cleanup } -result {0 1} test winFCmd-8.3 {TraversalCopy: DOTREE_POSTD} -setup { @@ -963,7 +963,7 @@ test winFCmd-9.3 {TraversalDelete: DOTREE_PRED} -setup { testfile rmdir -force td1 file exists td1 } -cleanup { - catch {testchmod 0666 td1} + catch {testchmod 0o666 td1} cleanup } -returnCodes error -result {td1 EACCES} test winFCmd-9.4 {TraversalDelete: DOTREE_POSTD} -setup { -- cgit v0.12 From 1bd8f407a5fc44a8b7a54bb78d8d29a2e5b0358f Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 18 Jul 2014 12:18:44 +0000 Subject: [b43f2b49f7] New compilation strategy for lappend that allows multi-value lappend to not have quadratic performance (through better reference management). --- generic/tclAssembly.c | 4 ++ generic/tclCompCmdsGR.c | 60 +++++------------ generic/tclCompile.c | 13 ++++ generic/tclCompile.h | 7 +- generic/tclExecute.c | 167 +++++++++++++++++++++++++++++++++++++++++++++++- 5 files changed, 206 insertions(+), 45 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index d1866c8..6d5676b 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -410,6 +410,10 @@ static const TalInstDesc TalInstructionTable[] = { {"lappendArray", ASSEM_LVT, (INST_LAPPEND_ARRAY1<<8 | INST_LAPPEND_ARRAY4),2, 1}, {"lappendArrayStk", ASSEM_1BYTE, INST_LAPPEND_ARRAY_STK, 3, 1}, + {"lappendList", ASSEM_LVT4, INST_LAPPEND_LIST, 1, 1}, + {"lappendListArray",ASSEM_LVT4, INST_LAPPEND_LIST_ARRAY,2, 1}, + {"lappendListArrayStk", ASSEM_1BYTE,INST_LAPPEND_LIST_ARRAY_STK, 3, 1}, + {"lappendListStk", ASSEM_1BYTE, INST_LAPPEND_LIST_STK, 2, 1}, {"lappendStk", ASSEM_1BYTE, INST_LAPPEND_STK, 2, 1}, {"le", ASSEM_1BYTE, INST_LE, 2, 1}, {"lindexMulti", ASSEM_LINDEX_MULTI, diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index b3e273f..166fea0 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -868,28 +868,16 @@ TclCompileLappendCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *varTokenPtr, *valueTokenPtr; - int isScalar, localIndex, numWords, i, fwd, offsetFwd; + int isScalar, localIndex, numWords, i; DefineLineInformation; /* TIP #280 */ - /* - * If we're not in a procedure, don't compile. - */ - - if (envPtr->procPtr == NULL) { - return TCL_ERROR; - } - /* TODO: Consider support for compiling expanded args. */ numWords = parsePtr->numWords; if (numWords == 1) { return TCL_ERROR; } - if (numWords != 3) { - /* - * LAPPEND instructions currently only handle one value, but we can - * handle some multi-value cases by stringing them together. - */ + if (numWords != 3 || envPtr->procPtr == NULL) { goto lappendMultiple; } @@ -943,42 +931,28 @@ TclCompileLappendCmd( return TCL_OK; lappendMultiple: - /* - * Can only handle the case where we are appending to a local scalar when - * there are multiple values to append. Fortunately, this is common. - */ - - if (envPtr->procPtr == NULL) { - return TCL_ERROR; - } varTokenPtr = TokenAfter(parsePtr->tokenPtr); - PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT, + PushVarNameWord(interp, varTokenPtr, envPtr, 0, &localIndex, &isScalar, 1); - if (!isScalar || localIndex < 0) { - return TCL_ERROR; - } - - /* - * Definitely appending to a local scalar; generate the words and append - * them. - */ - valueTokenPtr = TokenAfter(varTokenPtr); for (i = 2 ; i < numWords ; i++) { CompileWord(envPtr, valueTokenPtr, interp, i); valueTokenPtr = TokenAfter(valueTokenPtr); } - TclEmitInstInt4( INST_LIST, numWords-2, envPtr); - TclEmitInstInt4( INST_EXIST_SCALAR, localIndex, envPtr); - offsetFwd = CurrentOffset(envPtr); - TclEmitInstInt1( INST_JUMP_FALSE1, 0, envPtr); - Emit14Inst( INST_LOAD_SCALAR, localIndex, envPtr); - TclEmitInstInt4( INST_REVERSE, 2, envPtr); - TclEmitOpcode( INST_LIST_CONCAT, envPtr); - fwd = CurrentOffset(envPtr) - offsetFwd; - TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1); - Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr); - + TclEmitInstInt4( INST_LIST, numWords-2, envPtr); + if (isScalar) { + if (localIndex < 0) { + TclEmitOpcode( INST_LAPPEND_LIST_STK, envPtr); + } else { + TclEmitInstInt4(INST_LAPPEND_LIST, localIndex, envPtr); + } + } else { + if (localIndex < 0) { + TclEmitOpcode( INST_LAPPEND_LIST_ARRAY_STK, envPtr); + } else { + TclEmitInstInt4(INST_LAPPEND_LIST_ARRAY, localIndex,envPtr); + } + } return TCL_OK; } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 347e3f0..838b195 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -650,6 +650,19 @@ InstructionDesc const tclInstructionTable[] = { * satisfy the class check (standard definition of "all"). * Stack: ... stringValue => ... boolean */ + {"lappendList", 5, 0, 1, {OPERAND_LVT4}}, + /* Lappend list to scalar variable at op4 in frame. + * Stack: ... list => ... listVarContents */ + {"lappendListArray", 5, -1, 1, {OPERAND_LVT4}}, + /* Lappend list to array element; array at op4. + * Stack: ... elem list => ... listVarContents */ + {"lappendListArrayStk", 1, -2, 0, {OPERAND_NONE}}, + /* Lappend list to array element. + * Stack: ... arrayName elem list => ... listVarContents */ + {"lappendListStk", 1, -1, 0, {OPERAND_NONE}}, + /* Lappend list to general variable. + * Stack: ... varName list => ... listVarContents */ + {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 5665ca9..fa4a360 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -799,8 +799,13 @@ typedef struct ByteCode { #define INST_TRY_CVT_TO_BOOLEAN 183 #define INST_STR_CLASS 184 +#define INST_LAPPEND_LIST 185 +#define INST_LAPPEND_LIST_ARRAY 186 +#define INST_LAPPEND_LIST_ARRAY_STK 187 +#define INST_LAPPEND_LIST_STK 188 + /* The last opcode */ -#define LAST_INST_OPCODE 184 +#define LAST_INST_OPCODE 188 /* * Table describing the Tcl bytecode instructions: their name (for displaying diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 0cd074d..2098e50 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -3347,7 +3347,7 @@ TEBCresume( */ { - int storeFlags; + int storeFlags, len; case INST_STORE_ARRAY4: opnd = TclGetUInt4AtPtr(pc+1); @@ -3587,6 +3587,171 @@ TEBCresume( #endif TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_V(pcAdjustment, cleanup, 1); + + case INST_LAPPEND_LIST: + opnd = TclGetUInt4AtPtr(pc+1); + valuePtr = OBJ_AT_TOS; + varPtr = LOCAL(opnd); + cleanup = 1; + pcAdjustment = 5; + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr))); + if (TclListObjGetElements(interp, valuePtr, &objc, &objv) + != TCL_OK) { + TRACE_ERROR(interp); + goto gotError; + } + if (TclIsVarDirectReadable(varPtr) + && TclIsVarDirectWritable(varPtr)) { + goto lappendListDirect; + } + arrayPtr = NULL; + part1Ptr = part2Ptr = NULL; + goto lappendListPtr; + + case INST_LAPPEND_LIST_ARRAY: + opnd = TclGetUInt4AtPtr(pc+1); + valuePtr = OBJ_AT_TOS; + part1Ptr = NULL; + part2Ptr = OBJ_UNDER_TOS; + arrayPtr = LOCAL(opnd); + cleanup = 2; + pcAdjustment = 5; + while (TclIsVarLink(arrayPtr)) { + arrayPtr = arrayPtr->value.linkPtr; + } + TRACE(("%u \"%.30s\" \"%.30s\" => ", + opnd, O2S(part2Ptr), O2S(valuePtr))); + if (TclListObjGetElements(interp, valuePtr, &objc, &objv) + != TCL_OK) { + TRACE_ERROR(interp); + goto gotError; + } + if (TclIsVarArray(arrayPtr) && !ReadTraced(arrayPtr) + && !WriteTraced(arrayPtr)) { + varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr); + if (varPtr && TclIsVarDirectReadable(varPtr) + && TclIsVarDirectWritable(varPtr)) { + goto lappendListDirect; + } + } + varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, + TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr, opnd); + if (varPtr == NULL) { + TRACE_ERROR(interp); + goto gotError; + } + goto lappendListPtr; + + case INST_LAPPEND_LIST_ARRAY_STK: + pcAdjustment = 1; + cleanup = 3; + valuePtr = OBJ_AT_TOS; + part2Ptr = OBJ_UNDER_TOS; /* element name */ + part1Ptr = OBJ_AT_DEPTH(2); /* array name */ + TRACE(("\"%.30s(%.30s)\" \"%.30s\" => ", + O2S(part1Ptr), O2S(part2Ptr), O2S(valuePtr))); + goto lappendList; + + case INST_LAPPEND_LIST_STK: + pcAdjustment = 1; + cleanup = 2; + valuePtr = OBJ_AT_TOS; + part2Ptr = NULL; + part1Ptr = OBJ_UNDER_TOS; /* variable name */ + TRACE(("\"%.30s\" \"%.30s\" => ", O2S(part1Ptr), O2S(valuePtr))); + goto lappendList; + + lappendListDirect: + objResultPtr = varPtr->value.objPtr; + if (TclListObjLength(interp, objResultPtr, &len) != TCL_OK) { + TRACE_ERROR(interp); + goto gotError; + } + if (Tcl_IsShared(objResultPtr)) { + Tcl_Obj *newValue = Tcl_DuplicateObj(objResultPtr); + + TclDecrRefCount(objResultPtr); + varPtr->value.objPtr = objResultPtr = newValue; + Tcl_IncrRefCount(newValue); + } + if (Tcl_ListObjReplace(interp, objResultPtr, len, 0, objc, objv) + != TCL_OK) { + TRACE_ERROR(interp); + goto gotError; + } + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(pcAdjustment, cleanup, 1); + + lappendList: + opnd = -1; + if (TclListObjGetElements(interp, valuePtr, &objc, &objv) + != TCL_OK) { + TRACE_ERROR(interp); + goto gotError; + } + DECACHE_STACK_INFO(); + varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, + TCL_LEAVE_ERR_MSG, "set", 1, 1, &arrayPtr); + CACHE_STACK_INFO(); + if (!varPtr) { + TRACE_ERROR(interp); + goto gotError; + } + + lappendListPtr: + if (TclIsVarInHash(varPtr)) { + VarHashRefCount(varPtr)++; + } + if (arrayPtr && TclIsVarInHash(arrayPtr)) { + VarHashRefCount(arrayPtr)++; + } + DECACHE_STACK_INFO(); + objResultPtr = TclPtrGetVar(interp, varPtr, arrayPtr, + part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, opnd); + CACHE_STACK_INFO(); + if (TclIsVarInHash(varPtr)) { + VarHashRefCount(varPtr)--; + } + if (arrayPtr && TclIsVarInHash(arrayPtr)) { + VarHashRefCount(arrayPtr)--; + } + + { + int createdNewObj = 0; + + if (!objResultPtr) { + objResultPtr = valuePtr; + } else if (TclListObjLength(interp, objResultPtr, &len)!=TCL_OK) { + TRACE_ERROR(interp); + goto gotError; + } else { + if (Tcl_IsShared(objResultPtr)) { + objResultPtr = Tcl_DuplicateObj(objResultPtr); + createdNewObj = 1; + } + if (Tcl_ListObjReplace(interp, objResultPtr, len,0, objc,objv) + != TCL_OK) { + goto errorInLappendListPtr; + } + } + DECACHE_STACK_INFO(); + objResultPtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, + part2Ptr, objResultPtr, TCL_LEAVE_ERR_MSG, opnd); + CACHE_STACK_INFO(); + if (!objResultPtr) { + errorInLappendListPtr: + if (createdNewObj) { + TclDecrRefCount(objResultPtr); + } + TRACE_ERROR(interp); + goto gotError; + } + } + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(pcAdjustment, cleanup, 1); } /* -- cgit v0.12 From b32141b751698c59b7c8b574b52963976f3e0dd4 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 18 Jul 2014 22:05:16 +0000 Subject: [75b8433707] Plug a subtle memory leak in TclOO. Test suite very unhappy with this. Shoving into a mistake branch until that's sorted. --- generic/tclOO.c | 1 + tests/oo.test | 13 +++++++++++++ 2 files changed, 14 insertions(+) diff --git a/generic/tclOO.c b/generic/tclOO.c index de00733..74de6d0 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -1280,6 +1280,7 @@ TclOORemoveFromInstances( removeInstance: if (Deleted(clsPtr->thisPtr)) { + DelRef(clsPtr->instances.list[i]); clsPtr->instances.list[i] = NULL; } else { clsPtr->instances.num--; diff --git a/tests/oo.test b/tests/oo.test index d63e931..fcd9818 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -258,6 +258,19 @@ test oo-1.18 {OO: create object in NS with same name as global cmd} -setup { rename test-oo-1.18 {} A destroy } -result ::C +test oo-1.18.1 {Bug 75b8433707: memory leak in oo-1.18} -setup { + proc test-oo-1.18 {} return +} -constraints memory -body { + leaktest { + oo::class create A + oo::class create B {superclass A} + oo::define B constructor {} {A create test-oo-1.18} + B create C + A destroy + } +} -cleanup { + rename test-oo-1.18 {} +} -result 0 test oo-1.19 {basic test of OO functionality: teardown order} -body { oo::object create o namespace delete [info object namespace o] -- cgit v0.12 From 4a913825d6e04adfddffb4f70cd7d35ae6b92efb Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 21 Jul 2014 14:26:56 +0000 Subject: [e6477e1b0f] Plug memleak in AtForkChild() detected in iocmd-11.4. --- unix/tclUnixNotfy.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/unix/tclUnixNotfy.c b/unix/tclUnixNotfy.c index b234667..b2bea45 100644 --- a/unix/tclUnixNotfy.c +++ b/unix/tclUnixNotfy.c @@ -311,6 +311,7 @@ Tcl_InitNotifier(void) * pipe to the original notifier thread */ if (notifierCount > 0 && processIDInitialized != getpid()) { + Tcl_ConditionFinalize(¬ifierCV); notifierCount = 0; processIDInitialized = 0; close(triggerPipe); @@ -1375,8 +1376,7 @@ AtForkParent(void) static void AtForkChild(void) { - notifierMutex = NULL; - notifierCV = NULL; + Tcl_MutexFinalize(¬ifierMutex); Tcl_InitNotifier(); } #endif /* HAVE_PTHREAD_ATFORK */ -- cgit v0.12 From b48cbaeccb8ec71c06c18c3eec115aad92346c38 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 22 Jul 2014 16:44:38 +0000 Subject: [12b0997ce7] Plug memleak in iocmd.tf-32.0 . --- generic/tclIORChan.c | 63 +++++++++++++++++++++++++++++++++------------------- 1 file changed, 40 insertions(+), 23 deletions(-) diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index ff602c6..3506a44 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -436,6 +436,7 @@ static ReflectedChannelMap * GetReflectedChannelMap(Tcl_Interp *interp); static void DeleteReflectedChannelMap(ClientData clientData, Tcl_Interp *interp); static int ErrnoReturn(ReflectedChannel *rcPtr, Tcl_Obj *resObj); +static void MarkDead(ReflectedChannel *rcPtr); /* * Global constant strings (messages). ================== @@ -1146,7 +1147,6 @@ ReflectClose( if (result != TCL_OK) { FreeReceivedError(&p); } - return EOK; } #endif @@ -1217,17 +1217,14 @@ ReflectClose( if (hPtr) { Tcl_DeleteHashEntry(hPtr); } + } #endif - - tctPtr = ((Channel *)rcPtr->chan)->typePtr; - if (tctPtr && tctPtr != &tclRChannelType) { + tctPtr = ((Channel *)rcPtr->chan)->typePtr; + if (tctPtr && tctPtr != &tclRChannelType) { ckfree((char *)tctPtr); ((Channel *)rcPtr->chan)->typePtr = NULL; - } - Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); -#ifdef TCL_THREADS } -#endif + Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); return (result == TCL_OK) ? EOK : EINVAL; } @@ -2192,9 +2189,15 @@ FreeReflectedChannel( Channel *chanPtr = (Channel *) rcPtr->chan; Tcl_Release(chanPtr); - Tcl_DecrRefCount(rcPtr->name); - Tcl_DecrRefCount(rcPtr->methods); - Tcl_DecrRefCount(rcPtr->cmd); + if (rcPtr->name) { + Tcl_DecrRefCount(rcPtr->name); + } + if (rcPtr->methods) { + Tcl_DecrRefCount(rcPtr->methods); + } + if (rcPtr->cmd) { + Tcl_DecrRefCount(rcPtr->cmd); + } ckfree(rcPtr); } @@ -2460,6 +2463,28 @@ GetReflectedChannelMap( */ static void +MarkDead( + ReflectedChannel *rcPtr) +{ + if (rcPtr->dead) { + return; + } + if (rcPtr->name) { + Tcl_DecrRefCount(rcPtr->name); + rcPtr->name = NULL; + } + if (rcPtr->methods) { + Tcl_DecrRefCount(rcPtr->methods); + rcPtr->methods = NULL; + } + if (rcPtr->cmd) { + Tcl_DecrRefCount(rcPtr->cmd); + rcPtr->cmd = NULL; + } + rcPtr->dead = 1; +} + +static void DeleteReflectedChannelMap( ClientData clientData, /* The per-interpreter data structure. */ Tcl_Interp *interp) /* The interpreter being deleted. */ @@ -2494,7 +2519,7 @@ DeleteReflectedChannelMap( chan = Tcl_GetHashValue(hPtr); rcPtr = Tcl_GetChannelInstanceData(chan); - rcPtr->dead = 1; + MarkDead(rcPtr); Tcl_DeleteHashEntry(hPtr); } Tcl_DeleteHashTable(&rcmPtr->map); @@ -2577,7 +2602,7 @@ DeleteReflectedChannelMap( continue; } - rcPtr->dead = 1; + MarkDead(rcPtr); Tcl_DeleteHashEntry(hPtr); } #endif @@ -2724,7 +2749,7 @@ DeleteThreadReflectedChannelMap( Tcl_Channel chan = Tcl_GetHashValue(hPtr); ReflectedChannel *rcPtr = Tcl_GetChannelInstanceData(chan); - rcPtr->dead = 1; + MarkDead(rcPtr); Tcl_DeleteHashEntry(hPtr); } ckfree(rcmPtr); @@ -2907,8 +2932,6 @@ ForwardProc( * No parameters/results. */ - const Tcl_ChannelType *tctPtr; - if (InvokeTclMethod(rcPtr, METH_FINAL, NULL, NULL, &resObj)!=TCL_OK) { ForwardSetObjError(paramPtr, resObj); } @@ -2932,13 +2955,7 @@ ForwardProc( hPtr = Tcl_FindHashEntry(&rcmPtr->map, Tcl_GetChannelName(rcPtr->chan)); Tcl_DeleteHashEntry(hPtr); - - tctPtr = ((Channel *)rcPtr->chan)->typePtr; - if (tctPtr && tctPtr != &tclRChannelType) { - ckfree((char *)tctPtr); - ((Channel *)rcPtr->chan)->typePtr = NULL; - } - Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); + MarkDead(rcPtr); break; } -- cgit v0.12 From 531afdcf4e0d725402db70a2b207305dfa7f8903 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 22 Jul 2014 18:12:27 +0000 Subject: Avoid [thread::exit]; Using it leads to memleaks. --- tests/ioCmd.test | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 8d35ec7..dcca1f5 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -2814,7 +2814,9 @@ test iocmd.tf-24.17.bug3522560 {postevent for transfered channel} \ update } LOG THREAD-LOOP-DONE - thread::exit + #thread::exit + # Thread exits cause leaks; Use clean thread shutdown + set forever yourGirl } LOG MAIN_WAITING -- cgit v0.12 From 91e311e52d7fd08f0eb70ddd211e5aa51a5e2d22 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 22 Jul 2014 19:57:51 +0000 Subject: Workaround [info frame] troubles with -singleproc 1 testing operations. --- tests/all.tcl | 3 +++ 1 file changed, 3 insertions(+) diff --git a/tests/all.tcl b/tests/all.tcl index 05d3024..0a6f57f 100644 --- a/tests/all.tcl +++ b/tests/all.tcl @@ -15,5 +15,8 @@ package require Tcl 8.5 package require tcltest 2.2 namespace import tcltest::* configure {*}$argv -testdir [file dir [info script]] +if {[singleProcess]} { + interp debug {} -frame 1 +} runAllTests proc exit args {} -- cgit v0.12