diff options
| -rw-r--r-- | generic/tclTest.c | 54 | ||||
| -rw-r--r-- | tests/lrange.test | 26 |
2 files changed, 80 insertions, 0 deletions
diff --git a/generic/tclTest.c b/generic/tclTest.c index 45cca5a..0e34af7 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -220,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 TestpurebytesobjObjCmd(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[]); @@ -570,6 +573,7 @@ Tcltest_Init( Tcl_CreateObjCommand(interp, "gettimes", GetTimesObjCmd, NULL, NULL); Tcl_CreateCommand(interp, "noop", NoopCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testpurebytesobj", TestpurebytesobjObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testbytestring", TestbytestringObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testwrongnumargs", TestWrongNumArgsObjCmd, NULL, NULL); @@ -4959,6 +4963,56 @@ NoopObjCmd( /* *---------------------------------------------------------------------- * + * TestpurebytesobjObjCmd -- + * + * This object-based procedure constructs a pure bytes object + * without type and with internal representation containing NULL's. + * + * If no argument supplied it returns empty object with tclEmptyStringRep, + * otherwise it returns this as pure bytes object with bytes value equal + * string. + * + * Results: + * Returns the TCL_OK result code. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestpurebytesobjObjCmd( + ClientData unused, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* The argument objects. */ +{ + Tcl_Obj *objPtr; + + if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?string?"); + return TCL_ERROR; + } + objPtr = Tcl_NewObj(); + /* + objPtr->internalRep.twoPtrValue.ptr1 = NULL; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; + */ + memset(&objPtr->internalRep, 0, sizeof(objPtr->internalRep)); + if (objc == 2) { + const char *s = Tcl_GetStringFromObj(objv[1], &objPtr->length); + objPtr->bytes = ckalloc(objPtr->length + 1); + memcpy(objPtr->bytes, s, objPtr->length); + objPtr->bytes[objPtr->length] = 0; + } + Tcl_SetObjResult(interp, objPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TestbytestringObjCmd -- * * This object-based procedure constructs a string which can diff --git a/tests/lrange.test b/tests/lrange.test index 4ba645d..5bb4ee9 100644 --- a/tests/lrange.test +++ b/tests/lrange.test @@ -15,6 +15,12 @@ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } + +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + +testConstraint testpurebytesobj [llength [info commands testpurebytesobj]] + test lrange-1.1 {range of list elements} { lrange {a b c d} 1 2 @@ -117,6 +123,26 @@ test lrange-3.7b {not compiled on empty not canonical list (with static and dyna list [$cmd { } 0 1] [$cmd [format %c 32] 0 1] [$cmd [set a { }] 0 1] \ [$cmd { } 0-1 end+1] [$cmd [format %c 32] 0-1 end+1] [$cmd $a 0-1 end+1] } [lrepeat 6 {}] +# following 4 tests could cause a segfault on empty non-lists with tclEmptyStringRep +# (as before the fix [58c46e74b931d3a1]): +test lrange-3.7a.2 {compiled on empty not list object, 2nd regression test, bug [cc1e91552c]} { + list [lrange {} 0 1] [lrange [lindex a -1] 0 1] [lrange [set a {}] 0 1] \ + [lrange {} 0-1 end+1] [lrange [lindex a -1] 0-1 end+1] [lrange $a 0-1 end+1] +} [lrepeat 6 {}] +test lrange-3.7b.2 {not compiled on empty not list object, 2nd regression test, bug [cc1e91552c]} { + set cmd lrange + list [$cmd {} 0 1] [$cmd [lindex a -1] 0 1] [$cmd [set a {}] 0 1] \ + [$cmd {} 0-1 end+1] [$cmd [lindex a -1] 0-1 end+1] [$cmd $a 0-1 end+1] +} [lrepeat 6 {}] +test lrange-3.7c.2 {compiled on empty pure bytes object, 2nd regression test, bug [cc1e91552c]} { + list [lrange [testpurebytesobj] 0 1] [lrange [testpurebytesobj { }] 0 1] [lrange [set a [testpurebytesobj {}]] 0 1] \ + [lrange [testpurebytesobj] 0-1 end+1] [lrange [testpurebytesobj { }] 0-1 end+1] [lrange $a 0-1 end+1] +} [lrepeat 6 {}] +test lrange-3.7d.2 {not compiled on empty pure bytes object, 2nd regression test, bug [cc1e91552c]} { + set cmd lrange + list [$cmd [testpurebytesobj] 0 1] [$cmd [testpurebytesobj { }] 0 1] [$cmd [set a [testpurebytesobj {}]] 0 1] \ + [$cmd [testpurebytesobj] 0-1 end+1] [$cmd [testpurebytesobj { }] 0-1 end+1] [$cmd $a 0-1 end+1] +} [lrepeat 6 {}] # cleanup |