From 56ca2a64d7665bc088790e6cfa134b39a7d0034f Mon Sep 17 00:00:00 2001 From: griffin Date: Sun, 16 Jul 2023 00:24:54 +0000 Subject: Fix bug [c25d2cd3e6], as well as memory leaks in lsearch and concat. Add cleanup to some tests. Fix bug and leak in tclTestABSList.c Correct comment in tclArithSeries.c --- generic/tclArithSeries.c | 3 ++- generic/tclCmdIL.c | 24 ++++++++++++++++++++---- generic/tclTestABSList.c | 15 ++++++++++++--- generic/tclUtil.c | 2 ++ tests/abstractlist.test | 11 +++++++---- tests/lseq.test | 8 +++++--- 6 files changed, 48 insertions(+), 15 deletions(-) diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c index caf701b..166c1c9 100755 --- a/generic/tclArithSeries.c +++ b/generic/tclArithSeries.c @@ -588,11 +588,12 @@ TclNewArithSeriesObj( * * Results: * - * TCL_OK on success, TCL_ERROR on index out of range. + * TCL_OK on success. * * Side Effects: * * On success, the integer pointed by *element is modified. + * An empty string ("") is assigned if index is out-of-bounds. * *---------------------------------------------------------------------- */ diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index d52d6d5..663d962 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -2635,7 +2635,7 @@ Tcl_LpopObjCmd( Tcl_Size listLen; int copied = 0, result; Tcl_Obj *elemPtr, *stored; - Tcl_Obj *listPtr, **elemPtrs; + Tcl_Obj *listPtr; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "listvar ?index?"); @@ -2647,7 +2647,7 @@ Tcl_LpopObjCmd( return TCL_ERROR; } - result = TclListObjGetElementsM(interp, listPtr, &listLen, &elemPtrs); + result = TclListObjLengthM(interp, listPtr, &listLen); if (result != TCL_OK) { return result; } @@ -2666,7 +2666,12 @@ Tcl_LpopObjCmd( "OUTOFRANGE", NULL); return TCL_ERROR; } - elemPtr = elemPtrs[listLen - 1]; + + result = Tcl_ListObjIndex(interp, listPtr, (listLen-1), &elemPtr); + if (result != TCL_OK) { + return result; + } + Tcl_IncrRefCount(elemPtr); } else { elemPtr = TclLindexFlat(interp, listPtr, objc-2, objv+2); @@ -2699,7 +2704,13 @@ Tcl_LpopObjCmd( return result; } } else { - Tcl_Obj *newListPtr = TclLsetFlat(interp, listPtr, objc-2, objv+2, NULL); + Tcl_Obj *newListPtr; + Tcl_ObjTypeSetElement *proc = TclObjTypeHasProc(listPtr, setElementProc); + if (proc) { + newListPtr = proc(interp, listPtr, objc-2, objv+2, NULL); + } else { + newListPtr = TclLsetFlat(interp, listPtr, objc-2, objv+2, NULL); + } if (newListPtr == NULL) { if (copied) { Tcl_DecrRefCount(listPtr); @@ -3946,6 +3957,7 @@ Tcl_LsearchObjCmd( */ if (returnSubindices && (sortInfo.indexc != 0)) { + Tcl_BumpObj(itemPtr); itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo); Tcl_ListObjAppendElement(interp, listPtr, itemPtr); @@ -3953,6 +3965,7 @@ Tcl_LsearchObjCmd( Tcl_ListObjReplace(interp, listPtr, LIST_MAX, 0, groupSize, &listv[i]); } else { + Tcl_BumpObj(itemPtr); itemPtr = listv[i]; Tcl_ListObjAppendElement(interp, listPtr, itemPtr); } @@ -4023,6 +4036,9 @@ Tcl_LsearchObjCmd( */ done: + /* potential lingering abstract list element */ + Tcl_BumpObj(itemPtr); + if (startPtr != NULL) { Tcl_DecrRefCount(startPtr); } diff --git a/generic/tclTestABSList.c b/generic/tclTestABSList.c index f9f2fda..7ac6308 100644 --- a/generic/tclTestABSList.c +++ b/generic/tclTestABSList.c @@ -361,7 +361,6 @@ my_LStringObjSetElem( { LString *lstringRepPtr = (LString*)lstringObj->internalRep.twoPtrValue.ptr1; Tcl_Size index; - const char *newvalue; int status; Tcl_Obj *returnObj; @@ -385,8 +384,17 @@ my_LStringObjSetElem( lstringRepPtr->string = (char*)Tcl_Realloc(lstringRepPtr->string, lstringRepPtr->strlen+1); } - newvalue = Tcl_GetString(valueObj); - lstringRepPtr->string[index] = newvalue[0]; + if (valueObj) { + const char newvalue = Tcl_GetString(valueObj)[0]; + lstringRepPtr->string[index] = newvalue; + } else if (index < lstringRepPtr->strlen) { + /* Remove the char by sliding the tail of the string down */ + char *sptr = &lstringRepPtr->string[index]; + /* This is an overlapping copy, by definition */ + lstringRepPtr->strlen--; + memmove(sptr, (sptr+1), (lstringRepPtr->strlen - index)); + } + // else do nothing Tcl_InvalidateStringRep(returnObj); @@ -684,6 +692,7 @@ my_NewLStringObj( i++; } if (i != objc-1) { + Tcl_Free((char*)lstringRepPtr); Tcl_WrongNumArgs(interp, 0, objv, "lstring string"); return NULL; } diff --git a/generic/tclUtil.c b/generic/tclUtil.c index ac292db..1fdcda3 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -2005,8 +2005,10 @@ Tcl_ConcatObj( != Tcl_ListObjAppendList(NULL, resPtr, objPtr)) { /* Abandon ship! */ Tcl_DecrRefCount(resPtr); + Tcl_BumpObj(elemPtr); // could be an abstract list element goto slow; } + Tcl_BumpObj(elemPtr); // could be an an abstract list element } else { resPtr = TclDuplicatePureObj( NULL, objPtr, &tclListType); diff --git a/tests/abstractlist.test b/tests/abstractlist.test index 4335daa..5c92048 100644 --- a/tests/abstractlist.test +++ b/tests/abstractlist.test @@ -41,13 +41,15 @@ test abstractlist-1.1 {error cases} -body { } -returnCodes 1 \ -result {wrong # args: should be "lstring string"} -test abstractlist-2.0 {no shimmer llength} { +test abstractlist-2.0 {no shimmer llength} -body { set l [lstring $str] set l-isa [testobj objtype $l] set len [llength $l] set l-isa2 [testobj objtype $l] list $l ${l-isa} ${len} ${l-isa2} -} {{M y { } n a m e { } i s { } I n i g o { } M o n t o y a . { } Y o u { } k i l l e d { } m y { } f a t h e r . { } P r e p a r e { } t o { } d i e !} lstring 63 lstring} +} -cleanup { +unset l +} -result {{M y { } n a m e { } i s { } I n i g o { } M o n t o y a . { } Y o u { } k i l l e d { } m y { } f a t h e r . { } P r e p a r e { } t o { } d i e !} lstring 63 lstring} test abstractlist-2.1 {no shimmer lindex} { set l [lstring $str] @@ -501,14 +503,15 @@ test abstractlist-$not-4.11e {error case lset multiple indicies} \ -result {Multiple indicies not supported by lstring.} # lrepeat -test abstractlist-$not-4.12 {shimmer lrepeat} { +test abstractlist-$not-4.12 {shimmer lrepeat} -body { set l [lstring {*}$options Inconceivable] set l-isa [testobj objtype $l] set m [lrepeat 3 $l] set m-isa [testobj objtype $m] set n [lindex $m 1] list $l ${l-isa} $m ${m-isa} [testobj objtype $n] [value-cmp l n] -} {{I n c o n c e i v a b l e} lstring {{I n c o n c e i v a b l e} {I n c o n c e i v a b l e} {I n c o n c e i v a b l e}} list lstring 0} +} -cleanup { +} -result {{I n c o n c e i v a b l e} lstring {{I n c o n c e i v a b l e} {I n c o n c e i v a b l e} {I n c o n c e i v a b l e}} list lstring 0} # Disable constraint testConstraint [format "%sShimmer" [string totitle $not]] 1 diff --git a/tests/lseq.test b/tests/lseq.test index 6082856..4544675 100644 --- a/tests/lseq.test +++ b/tests/lseq.test @@ -455,7 +455,7 @@ test lseq-3.31 {lreverse inplace with doubles} {arithSeriesDouble} { # lsearch - # -- should not shimmer lseq list # -- should not leak lseq elements -test lseq-3.32 {lsearch nested lists of lseq} arithSeriesShimmer { +test lseq-3.32 {lsearch nested lists of lseq} -constraints arithSeriesShimmer -body { set srchlist {} for {set i 5} {$i < 25} {incr i} { lappend srchlist [lseq $i count 7 by 3] @@ -464,7 +464,9 @@ test lseq-3.32 {lsearch nested lists of lseq} arithSeriesShimmer { set b [lmap i $a {lindex [tcl::unsupported::representation $i] 3}] list [lindex [tcl::unsupported::representation $a] 3] $a $b \ [lindex [tcl::unsupported::representation [lindex $srchlist 15]] 3] -} {list {{20 23 26 29 32 35 38}} arithseries arithseries} +} -cleanup { + unset a b srchlist i +} -result {list {{20 23 26 29 32 35 38}} arithseries arithseries} # lsearch - @@ -725,7 +727,7 @@ test lseq-bug-54329e39c7 {does not cause memory bloat} -constraints { set premem [memusage] p $l set postmem [memusage] - expr {($postmem - $premem) < 10} + expr {[string match *purify* [tcl::build-info]] || ($postmem - $premem < 10) ? 1 : ($postmem - $premem)} } -result 1 # cleanup -- cgit v0.12