From f13b7726c4db8ae40da10effbd492cefd7aca015 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 10 Mar 2020 13:51:25 +0000 Subject: Fix Windows build, broken by [d5175f6050e308f4] --- generic/tclZipfs.c | 4 ++-- win/tclWinPipe.c | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index f9a6a8f..4901292 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -4899,10 +4899,10 @@ TclZipfs_AppHook( #ifdef SUPPORT_BUILTIN_ZIP_INSTALL int *argcPtr, /* Pointer to argc */ #else - TCL_UNUSED(int *) /*argcPtr*/, + TCL_UNUSED(int *), /*argcPtr*/ #endif #ifdef _WIN32 - TCL_UNUSED(WCHAR ***)argvPtr, + TCL_UNUSED(WCHAR ***)) /* argvPtr */ #else /* !_WIN32 */ char ***argvPtr) /* Pointer to argv */ #endif /* _WIN32 */ diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index 7066bd2..67cca32 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -363,7 +363,7 @@ PipeSetupProc( static void PipeCheckProc( - TCL_UNUNSED(ClientData), + TCL_UNUSED(ClientData), int flags) /* Event flags as passed to Tcl_DoOneEvent. */ { PipeInfo *infoPtr; -- cgit v0.12 From 72f5a0b42fd69b0ccad811c45ab2d2b265a67b63 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 11 Mar 2020 10:20:51 +0000 Subject: Put back dummy Tcl_DriverCloseProc/Tcl_DriverSeekProc (just defined as "void"). Needed to make Tk compile with C++ against 9.0 headers. --- generic/tcl.h | 2 ++ 1 file changed, 2 insertions(+) diff --git a/generic/tcl.h b/generic/tcl.h index 29f64bc..874f6e9 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -1240,12 +1240,14 @@ typedef void (Tcl_ScaleTimeProc) (Tcl_Time *timebuf, void *clientData); */ typedef int (Tcl_DriverBlockModeProc) (void *instanceData, int mode); +typedef void Tcl_DriverCloseProc; typedef int (Tcl_DriverClose2Proc) (void *instanceData, Tcl_Interp *interp, int flags); typedef int (Tcl_DriverInputProc) (void *instanceData, char *buf, int toRead, int *errorCodePtr); typedef int (Tcl_DriverOutputProc) (void *instanceData, const char *buf, int toWrite, int *errorCodePtr); +typedef void Tcl_DriverSeekProc; typedef int (Tcl_DriverSetOptionProc) (void *instanceData, Tcl_Interp *interp, const char *optionName, const char *value); -- cgit v0.12 From 14fd6b059e2e8ea5c2d5758b8a2800f3413e02f3 Mon Sep 17 00:00:00 2001 From: sebres Date: Wed, 11 Mar 2020 15:33:28 +0000 Subject: lpop.test: added test illustrating segfault in [234d6c811d] (and small review - stability of tests depending on outside circumstances, e. g. in case of -singleproc) --- tests/lpop.test | 33 +++++++++++++++++++-------------- 1 file changed, 19 insertions(+), 14 deletions(-) diff --git a/tests/lpop.test b/tests/lpop.test index 89b651c..3e28978 100644 --- a/tests/lpop.test +++ b/tests/lpop.test @@ -16,6 +16,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +unset -nocomplain no; # following tests expecting var "no" does not exists test lpop-1.1 {error conditions} -returnCodes error -body { lpop no } -result {can't read "no": no such variable} @@ -23,32 +24,36 @@ test lpop-1.2 {error conditions} -returnCodes error -body { lpop no 0 } -result {can't read "no": no such variable} test lpop-1.3 {error conditions} -returnCodes error -body { - set no "x {}x" - lpop no + set l "x {}x" + lpop l } -result {list element in braces followed by "x" instead of space} test lpop-1.4 {error conditions} -returnCodes error -body { - set no "x y" - lpop no -1 + set l "x y" + lpop l -1 } -result {index "-1" out of range} +test lpop-1.4b {error conditions (also check SF on empty list variable, bug [234d6c811d])} -body { + set l "x y" + list [lpop l] [lpop l] [catch {lpop l} v] $v [catch {lpop l 0} v] $v $l +} -result {y x 1 {index "end" out of range} 1 {index "0" out of range} {}} test lpop-1.5 {error conditions} -returnCodes error -body { - set no "x y z" - lpop no 3 + set l "x y z" + lpop l 3 } -result {index "3" out of range} ;#-errorCode {TCL OPERATION LPOP BADINDEX} test lpop-1.6 {error conditions} -returnCodes error -body { - set no "x y" - lpop no end+1 + set l "x y" + lpop l end+1 } -result {index "end+1" out of range} test lpop-1.7 {error conditions} -returnCodes error -body { - set no "x y" - lpop no {} + set l "x y" + lpop l {} } -match glob -result {bad index *} test lpop-1.8 {error conditions} -returnCodes error -body { - set no "x y" - lpop no 0 0 0 0 1 + set l "x y" + lpop l 0 0 0 0 1 } -result {index "1" out of range} test lpop-1.9 {error conditions} -returnCodes error -body { - set no "x y" - lpop no {1 0} + set l "x y" + lpop l {1 0} } -match glob -result {bad index *} test lpop-2.1 {basic functionality} -body { -- cgit v0.12 From 7cf28a1e23e36cae089d6ed13eeecf2d0b618f97 Mon Sep 17 00:00:00 2001 From: sebres Date: Wed, 11 Mar 2020 15:48:07 +0000 Subject: close [234d6c811d]: fixed segfault on empty list variable by "lpop" without index --- generic/tclCmdIL.c | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index f74368a..94ff2cc 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -2587,6 +2587,14 @@ Tcl_LpopObjCmd( */ if (objc == 2) { + if (!listLen) { + /* empty list, throw the same error as with index "end" */ + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "index \"end\" out of range", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX" + "OUTOFRANGE", NULL); + return TCL_ERROR; + } elemPtr = elemPtrs[listLen - 1]; Tcl_IncrRefCount(elemPtr); } else { -- cgit v0.12 From 46e5b17ffbd7d678e0113f8564deaeb32f137a82 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 12 Mar 2020 17:29:33 +0000 Subject: Add some testing of Tcl_SetByteArrayLength(). --- generic/tclTest.c | 48 ++++++++++++++++++++++++++++++++++++++++++++++++ tests/binary.test | 11 +++++++++++ 2 files changed, 59 insertions(+) diff --git a/generic/tclTest.c b/generic/tclTest.c index 5e807d4..3e942bb 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -226,6 +226,9 @@ static int TestbumpinterpepochObjCmd(ClientData clientData, static int TestpurebytesobjObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +static int TestsetbytearraylengthObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); static int TestbytestringObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -577,6 +580,7 @@ Tcltest_Init( Tcl_CreateCommand(interp, "noop", NoopCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testpurebytesobj", TestpurebytesobjObjCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testsetbytearraylength", TestsetbytearraylengthObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testbytestring", TestbytestringObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testwrongnumargs", TestWrongNumArgsObjCmd, NULL, NULL); @@ -5037,6 +5041,50 @@ TestpurebytesobjObjCmd( /* *---------------------------------------------------------------------- * + * TestsetbytearraylengthObjCmd -- + * + * Testing command 'testsetbytearraylength` used to test the public + * interface routine Tcl_SetByteArrayLength(). + * + * Results: + * Returns the TCL_OK result code. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestsetbytearraylengthObjCmd( + ClientData unused, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* The argument objects. */ +{ + int n; + Tcl_Obj *obj = NULL; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "value length"); + return TCL_ERROR; + } + if (TCL_OK != Tcl_GetIntFromObj(interp, objv[2], &n)) { + return TCL_ERROR; + } + if (Tcl_IsShared(objv[1])) { + obj = Tcl_DuplicateObj(objv[1]); + } else { + obj = objv[1]; + } + Tcl_SetByteArrayLength(obj, n); + Tcl_SetObjResult(interp, obj); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TestbytestringObjCmd -- * * This object-based procedure constructs a string which can diff --git a/tests/binary.test b/tests/binary.test index 8c1dedb..92fb648 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -2889,6 +2889,17 @@ test binary-76.2 {binary string appending growth algorithm} win { # Append to it string length [append str [binary format a* foo]] } 3 + +testConstraint testsetbytearraylength \ + [expr {"testsetbytearraylength" in [info commands]}] + +test binary-77.1 {Tcl_SetByteArrayLength} testsetbytearraylength { + testsetbytearraylength [string cat A B C] 1 +} A +test binary-77.2 {Tcl_SetByteArrayLength} testsetbytearraylength { + testsetbytearraylength [string cat \u0141 B C] 1 +} A + # ---------------------------------------------------------------------- # cleanup -- cgit v0.12 From 5d52fb6a3f7a73e612fadb45f4b0c09c45df7317 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 12 Mar 2020 17:37:16 +0000 Subject: Renumber tests to account for later releases. --- tests/binary.test | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/binary.test b/tests/binary.test index 92fb648..b872a30 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -2893,10 +2893,10 @@ test binary-76.2 {binary string appending growth algorithm} win { testConstraint testsetbytearraylength \ [expr {"testsetbytearraylength" in [info commands]}] -test binary-77.1 {Tcl_SetByteArrayLength} testsetbytearraylength { +test binary-79.1 {Tcl_SetByteArrayLength} testsetbytearraylength { testsetbytearraylength [string cat A B C] 1 } A -test binary-77.2 {Tcl_SetByteArrayLength} testsetbytearraylength { +test binary-79.2 {Tcl_SetByteArrayLength} testsetbytearraylength { testsetbytearraylength [string cat \u0141 B C] 1 } A -- cgit v0.12 From 442f4cfd687d3869bbaf7beb1431592c29934c33 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 12 Mar 2020 20:54:09 +0000 Subject: Minimal fix for crash bug. --- generic/tclBinary.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index f0fc866..f7fdd9f 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -535,6 +535,7 @@ Tcl_SetByteArrayLength( SET_BYTEARRAY(irPtr, byteArrayPtr); } TclInvalidateStringRep(objPtr); + objPtr->typePtr = &properByteArrayType; byteArrayPtr->used = newLength; return byteArrayPtr->bytes; } @@ -851,6 +852,7 @@ TclAppendBytesToByteArray( } byteArrayPtr->used += length; TclInvalidateStringRep(objPtr); + objPtr->typePtr = &properByteArrayType; } /* -- cgit v0.12 From 068df4904b6c2f08348f62aa2f06b2103c8aae79 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 13 Mar 2020 11:01:34 +0000 Subject: reformat assemble-15.* test-cases --- tests/assemble.test | 80 ++++++++++++++++++----------------------------------- 1 file changed, 27 insertions(+), 53 deletions(-) diff --git a/tests/assemble.test b/tests/assemble.test index 40c132d..45368de 100644 --- a/tests/assemble.test +++ b/tests/assemble.test @@ -1535,61 +1535,35 @@ test assemble-14.7 {incrArrayStkImm} { # assemble-15 - listIndexImm -test assemble-15.1 {listIndexImm - wrong # args} { - -body { - assemble {listIndexImm} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-15.2 {listIndexImm - wrong # args} { - -body { - assemble {listIndexImm too many} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-15.3 {listIndexImm - bad substitution} { - -body { - list [catch {assemble {listIndexImm $foo}} result] $result $::errorCode - } - -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} - -cleanup {unset result} -} -test assemble-15.4 {listIndexImm - invalid index} { - -body { - assemble {listIndexImm rubbish} - } - -returnCodes error - -match glob - -result {bad index "rubbish"*} -} -test assemble-15.5 {listIndexImm} { - -body { - assemble {push {a b c}; listIndexImm 2} - } - -result c -} -test assemble-15.6 {listIndexImm} { - -body { - assemble {push {a b c}; listIndexImm end-1} - } - -result b -} -test assemble-15.7 {listIndexImm} { - -body { - assemble {push {a b c}; listIndexImm end} - } - -result c -} -test assemble-15.8 {listIndexImm} { +test assemble-15.1 {listIndexImm - wrong # args} -body { + assemble {listIndexImm} +} -returnCodes error -match glob -result {wrong # args*} +test assemble-15.2 {listIndexImm - wrong # args} -body { + assemble {listIndexImm too many} +} -returnCodes error -match glob -result {wrong # args*} +test assemble-15.3 {listIndexImm - bad substitution} -body { + list [catch {assemble {listIndexImm $foo}} result] $result $::errorCode +} -cleanup { + unset result +} -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} +test assemble-15.4 {listIndexImm - invalid index} -body { + assemble {listIndexImm rubbish} +} -returnCodes error -match glob -result {bad index "rubbish"*} +test assemble-15.5 {listIndexImm} -body { + assemble {push {a b c}; listIndexImm 2} +} -result c +test assemble-15.6 {listIndexImm} -body { + assemble {push {a b c}; listIndexImm end-1} +} -result b +test assemble-15.7 {listIndexImm} -body { + assemble {push {a b c}; listIndexImm end} +} -result c +test assemble-15.8 {listIndexImm} -body { assemble {push {a b c}; listIndexImm end+2} -} {} -test assemble-15.9 {listIndexImm} { +} -result {} +test assemble-15.9 {listIndexImm} -body { assemble {push {a b c}; listIndexImm -1-1} -} {} +} -result {} # assemble-16 - invokeStk -- cgit v0.12