merge 8.5 (closes [5d989f9ba3]: avoid segfault by OOM if too many items to sort)

2 files changed, 54 insertions, 2 deletions

diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 94c5413..a73a292 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -3652,9 +3652,11 @@ Tcl_LsortObjCmd(
     int sortMode = SORTMODE_ASCII;
     int group, groupSize, groupOffset, idx, allocatedIndexVector = 0;
     Tcl_Obj *resultPtr, *cmdPtr, **listObjPtrs, *listObj, *indexPtr;
+    size_t elmArrSize;
     SortElement *elementArray = NULL, *elementPtr;
     SortInfo sortInfo;		/* Information about this sort that needs to
 				 * be passed to the comparison function. */
+#   define MAXCALLOC 1024000
 #   define NUM_LISTS 30
     SortElement *subList[NUM_LISTS+1];
 				/* This array holds pointers to temporary
@@ -3977,7 +3979,19 @@ Tcl_LsortObjCmd(
      * begins sorting it into the sublists as it appears.
      */
 
-    elementArray = ckalloc(length * sizeof(SortElement));
+    elmArrSize = length * sizeof(SortElement);
+    if (elmArrSize <= MAXCALLOC) {
+	elementArray = ckalloc(elmArrSize);
+    } else {
+	elementArray = malloc(elmArrSize);
+    }
+    if (!elementArray) {
+	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		"no enough memory to proccess sort of %d items", length));
+	Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+	sortInfo.resultCode = TCL_ERROR;
+	goto done;
+    }
 
     for (i=0; i < length; i++){
 	idx = groupSize * i + groupOffset;
@@ -4110,7 +4124,11 @@ Tcl_LsortObjCmd(
 	TclStackFree(interp, sortInfo.indexv);
     }
     if (elementArray) {
-	ckfree(elementArray);
+	if (elmArrSize <= MAXCALLOC) {
+	    ckfree((char *)elementArray);
+	} else {
+	    free((char *)elementArray);
+	}
     }
     return sortInfo.resultCode;
 }
diff --git a/tests/cmdIL.test b/tests/cmdIL.test
index 68122dd..0a1e24d 100644
--- a/tests/cmdIL.test
+++ b/tests/cmdIL.test
@@ -19,6 +19,7 @@ catch [list package require -exact Tcltest [info patchlevel]]
 # Used for constraining memory leak tests
 testConstraint memory [llength [info commands memory]]
 testConstraint testobj [llength [info commands testobj]]
+testConstraint prlimit [expr {[testConstraint macOrUnix] && ![catch { exec prlimit -n }]}]
 
 test cmdIL-1.1 {Tcl_LsortObjCmd procedure} -returnCodes error -body {
     lsort
@@ -504,6 +505,39 @@ test cmdIL-5.5 {lsort with list style index and sharing} -body {
 test cmdIL-5.6 {lsort with multiple list-style index options} {
     lsort -index {1 2 3} -index 0 {{a b} {c d} {b e}}
 } {{a b} {b e} {c d}}
+test cmdIL-5.7 {lsort memory exhaustion} -constraints {prlimit} -body {
+    # test it in child process (with limited address space):
+    set pipe {}
+    if {[catch {
+	set pipe [open |[list [interpreter]] r+]
+	exec prlimit -p [pid $pipe] --as=80000000
+    } msg]} {
+	catch {close $pipe}
+	tcltest::Skip "prlimit: error - [regsub {^\s*([^\n]*).*$} $msg {\1}]"
+    }
+    # if no error (enough memory), or error by list creation - add it as skipped test:
+    if {![catch {
+	chan configure $pipe -buffering line
+	puts $pipe {
+	    # create list and get length (avoid too long output in interactive shells):
+	    llength [set l [lrepeat 4000000 ""]]
+	    # test OOM:
+	    puts [llength [lsort $l]]
+	    exit
+	}
+	set result [read $pipe]
+	close $pipe
+	set pipe {}
+	set result
+    } result] || [regexp {^(?:list creation failed|unable to (?:re)?alloc)} $result]} {
+	tcltest::Skip "prlimit: wrong AS-limit, result: $result"
+    }
+    set result
+    # expecting error no memory by sort
+} -cleanup {
+    if {$pipe ne ""} { catch { close $pipe } }
+    unset -nocomplain pipe line result
+} -result {no enough memory to proccess sort of 4000000 items}
 
 # Compiled version
 test cmdIL-6.1 {lassign command syntax} -returnCodes error -body {