merge 8.7

3 files changed, 112 insertions, 33 deletions

diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl
index c51467b..e5cfc77 100644
--- a/library/tcltest/tcltest.tcl
+++ b/library/tcltest/tcltest.tcl
@@ -970,7 +970,7 @@ proc tcltest::testConstraint {constraint {value ""}} {
 	return $testConstraints($constraint)
     }
     # Check for boolean values
-    if {[catch {expr {$value && $value}} msg]} {
+    if {[catch {expr {$value && 1}} msg]} {
 	return -code error $msg
     }
     if {[limitConstraints] && ($constraint ni $Option(-constraints))} {
diff --git a/tests/cmdIL.test b/tests/cmdIL.test
index be4d2d6..05b5040 100644
--- a/tests/cmdIL.test
+++ b/tests/cmdIL.test
@@ -19,7 +19,8 @@ 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 }]}]
+source [file join [file dirname [info script]] internals.tcl]
+namespace import -force ::tcltest::internals::*
 
 test cmdIL-1.1 {Tcl_LsortObjCmd procedure} -returnCodes error -body {
     lsort
@@ -520,39 +521,21 @@ 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}]"
+test cmdIL-5.7 {lsort memory exhaustion} -constraints {testWithLimit} -body {
+    # test it in child process (with limited address space) ca. 80MB extra memory
+    # on x64 system it would be not enough to sort 4M items (the half 2M only),
+    # warn and skip if no error (enough memory) or error by list creation:
+    testWithLimit \
+	-warn-on-code 0 -warn-on-alloc-error 1 \
+	-addmem [expr {$tcl_platform(pointerSize)*4000000 + $tcl_platform(pointerSize)*3*2000000}] \
+    {
+	# create list and get length (avoid too long output in interactive shells):
+	llength [set l [lrepeat 4000000 ""]]
+	# test OOM:
+	llength [lsort $l]
     }
-    # 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}
+} -returnCodes 1 -result {no enough memory to proccess sort of 4000000 items}
 
 # Compiled version
 test cmdIL-6.1 {lassign command syntax} -returnCodes error -body {
diff --git a/tests/internals.tcl b/tests/internals.tcl
new file mode 100644
index 0000000..6b5bb87
--- /dev/null
+++ b/tests/internals.tcl
@@ -0,0 +1,96 @@
+# This file contains internal facilities for Tcl tests.
+#
+# Source this file in the related tests to include from tcl-tests:
+#
+#   source [file join [file dirname [info script]] internals.tcl]
+#
+# Copyright (c) 2020 Sergey G. Brester (sebres).
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+if {[namespace which -command ::tcltest::internals::scriptpath] eq ""} {namespace eval ::tcltest::internals {
+
+namespace path ::tcltest
+
+::tcltest::ConstraintInitializer testWithLimit { expr {[testConstraint macOrUnix] && ![catch { exec prlimit --version }]} }
+
+# test-with-limit --
+#
+# Usage: test-with-limit ?-addmem bytes? ?-maxmem bytes? command
+# Options:
+#	-addmem - set additional memory limit (in bytes) as difference (extra memory needed to run a test)
+#	-maxmem - set absolute maximum address space limit (in bytes)
+# 
+proc testWithLimit args {
+    set body [lindex $args end]
+    array set in [lrange $args 0 end-1]
+    # test in child process (with limits):
+    set pipe {}
+    if {[catch {
+	# start new process:
+	set pipe [open |[list [interpreter]] r+]
+	set ppid [pid $pipe]
+	# create prlimit args:
+	set args {}
+	# with limited address space:
+	if {[info exists in(-addmem)] || [info exists in(-maxmem)]} {
+	    if {[info exists in(-addmem)]} {
+		# as differnce to normal usage, so try to retrieve current memory usage:
+		if {[catch {
+		    # using ps (vsz is in KB):
+		    incr in(-addmem) [expr {[lindex [exec ps -hq $ppid -o vsz] end] * 1024}]
+		}]} {
+		    # ps failed, use default size 20MB:
+		    incr in(-addmem) 20000000
+		    # + size of locale-archive (may be up to 100MB):
+		    incr in(-addmem) [expr {
+			[file exists /usr/lib/locale/locale-archive] ? 
+			[file size /usr/lib/locale/locale-archive] : 0
+		    }]
+		}
+		if {![info exists in(-maxmem)]} {
+		    set in(-maxmem) $in(-addmem)
+		}
+		set in(-maxmem) [expr { max($in(-addmem), $in(-maxmem)) }]
+	    }
+	    append args --as=$in(-maxmem)
+	}
+	# apply limits:
+	exec prlimit -p $ppid {*}$args
+    } msg opt]} {
+	catch {close $pipe}
+	tcltest::Warn "testWithLimit: error - [regsub {^\s*([^\n]*).*$} $msg {\1}]"
+	tcltest::Skip testWithLimit
+    }
+    # execute body, close process and return:
+    set ret [catch {
+	chan configure $pipe -buffering line
+	puts $pipe "puts \[$body\]"
+	puts $pipe exit
+	set result [read $pipe]
+	close $pipe
+	set pipe {}
+	set result
+    } result opt]
+    if {$pipe ne ""} { catch { close $pipe } }
+    if {$ret && [dict get $opt -errorcode] eq "BYPASS-SKIPPED-TEST"} {
+	return {*}$opt $result
+    }
+    if { ( [info exists in(-warn-on-code)] && $ret in $in(-warn-on-code) )
+      || ( $ret && [info exists in(-warn-on-alloc-error)] && $in(-warn-on-alloc-error)
+      	    && [regexp {\munable to (?:re)?alloc\M} $result] )
+    } {
+	tcltest::Warn "testWithLimit: wrong limit, result: $result"
+	tcltest::Skip testWithLimit
+    }
+    return {*}$opt $result
+}
+
+# export all routines starting with test
+namespace export test*
+
+# for script path & as mark for loaded
+proc scriptpath {} [list return [info script]]
+
+}}; # end of internals.
\ No newline at end of file