From 57321fa4a4c4133d207d8d17123ae0037d162538 Mon Sep 17 00:00:00 2001 From: sebres Date: Wed, 29 Jan 2020 16:50:56 +0000 Subject: better test covering [5d989f9ba3] - limiting AS considers normal memory usage of process; prepared for new common test-facility (test-with-limit) for resticted execution --- tests/cmdIL.test | 59 +++++++++++++++++++++++++++++++++++++++++--------------- 1 file changed, 43 insertions(+), 16 deletions(-) diff --git a/tests/cmdIL.test b/tests/cmdIL.test index fabedea..c2b4615 100644 --- a/tests/cmdIL.test +++ b/tests/cmdIL.test @@ -446,38 +446,65 @@ test cmdIL-5.5 {lsort with list style index and sharing} -body { } -result 0 -cleanup { rename test_lsort "" } -test cmdIL-5.7 {lsort memory exhaustion} -constraints {prlimit} -body { - # test it in child process (with limited address space): +proc test-with-limit 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+] - exec prlimit -p [pid $pipe] --as=80000000 - } msg]} { + set ppid [pid $pipe] + # create prlimit args: + set args {} + if {[info exists in(-memory)]} { + # with limited address space, so try to retrieve current memory (using ps, vsz is in KB): + if {[catch { + incr in(-memory) [expr {[lindex [exec ps -hq $ppid -o vsz] end] * 1024}] + }]} { + # ps failed, use default size 20MB: + incr in(-memory) 20000000 + # + size of locale-archive (may be up to 100MB): + incr in(-memory) [expr { + [file exists /usr/lib/locale/locale-archive] ? [file size /usr/lib/locale/locale-archive] : 0 + }] + } + append args --as=$in(-memory) + } + # apply limits: + exec prlimit -p $ppid {*}$args + } msg opt]} { 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 { + 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 - } + puts $pipe "puts \[$body\]" + puts $pipe exit set result [read $pipe] close $pipe set pipe {} set result - } result] || [regexp {^(?:list creation failed|unable to alloc)} $result]} { + } result opt + if {$pipe ne ""} { catch { close $pipe } } + return {*}$opt $result +} +test cmdIL-5.7 {lsort memory exhaustion} -constraints {prlimit} -body { + # test it in child process (with limited address space): + if {![catch { + # ca. 80MB extra memory on x64 system would be enough to sort the half (2M) items: + test-with-limit -memory [expr {$tcl_platform(pointerSize)*3 * 2000000 + $tcl_platform(pointerSize)*4000000}] { + # create list and get length (avoid too long output in interactive shells): + llength [set l [lrepeat 4000000 ""]] + # test OOM: + llength [lsort $l] + } + } 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 -- cgit v0.12 From 782689d5eb24cd73d2dfaef376d4412246ec6cfa Mon Sep 17 00:00:00 2001 From: sebres Date: Wed, 29 Jan 2020 17:02:16 +0000 Subject: small amend (comments only) --- tests/cmdIL.test | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/tests/cmdIL.test b/tests/cmdIL.test index c2b4615..b57f1ac 100644 --- a/tests/cmdIL.test +++ b/tests/cmdIL.test @@ -477,7 +477,7 @@ proc test-with-limit args { 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: + # execute body, close process and return: catch { chan configure $pipe -buffering line puts $pipe "puts \[$body\]" @@ -493,13 +493,14 @@ proc test-with-limit args { test cmdIL-5.7 {lsort memory exhaustion} -constraints {prlimit} -body { # test it in child process (with limited address space): if {![catch { - # ca. 80MB extra memory on x64 system would be enough to sort the half (2M) items: + # ca. 80MB extra memory on x64 system would be not enough to sort 4M items (the half 2M only): test-with-limit -memory [expr {$tcl_platform(pointerSize)*3 * 2000000 + $tcl_platform(pointerSize)*4000000}] { # 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: } result] || [regexp {^(?:list creation failed|unable to (?:re)?alloc)} $result]} { tcltest::Skip "prlimit: wrong AS-limit, result: $result" } -- cgit v0.12 From f05d9af86d492cd0b158969b5190ccc651e91db4 Mon Sep 17 00:00:00 2001 From: sebres Date: Thu, 30 Jan 2020 15:32:51 +0000 Subject: introduces new command and constraint testWithLimit (as include tests/internals.tcl) that can be used to test a code under restricted circumstances (e.g. limited address space) --- library/tcltest/tcltest.tcl | 2 +- tests/cmdIL.test | 75 +++++++---------------------------- tests/internals.tcl | 96 +++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 112 insertions(+), 61 deletions(-) create mode 100644 tests/internals.tcl diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index e0c925a..1394949 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 b57f1ac..4a59177 100644 --- a/tests/cmdIL.test +++ b/tests/cmdIL.test @@ -15,7 +15,8 @@ if {[lsearch [namespace children] ::tcltest] == -1} { # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] -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} { list [catch {lsort} msg] $msg @@ -446,67 +447,21 @@ test cmdIL-5.5 {lsort with list style index and sharing} -body { } -result 0 -cleanup { rename test_lsort "" } -proc test-with-limit 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 {} - if {[info exists in(-memory)]} { - # with limited address space, so try to retrieve current memory (using ps, vsz is in KB): - if {[catch { - incr in(-memory) [expr {[lindex [exec ps -hq $ppid -o vsz] end] * 1024}] - }]} { - # ps failed, use default size 20MB: - incr in(-memory) 20000000 - # + size of locale-archive (may be up to 100MB): - incr in(-memory) [expr { - [file exists /usr/lib/locale/locale-archive] ? [file size /usr/lib/locale/locale-archive] : 0 - }] - } - append args --as=$in(-memory) - } - # apply limits: - exec prlimit -p $ppid {*}$args - } msg opt]} { - catch {close $pipe} - tcltest::Skip "prlimit: error - [regsub {^\s*([^\n]*).*$} $msg {\1}]" - } - # execute body, close process and return: - 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 } } - return {*}$opt $result -} -test cmdIL-5.7 {lsort memory exhaustion} -constraints {prlimit} -body { - # test it in child process (with limited address space): - if {![catch { - # ca. 80MB extra memory on x64 system would be not enough to sort 4M items (the half 2M only): - test-with-limit -memory [expr {$tcl_platform(pointerSize)*3 * 2000000 + $tcl_platform(pointerSize)*4000000}] { - # 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: - } result] || [regexp {^(?:list creation failed|unable to (?:re)?alloc)} $result]} { - tcltest::Skip "prlimit: wrong AS-limit, result: $result" +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] } - set result # expecting error no memory by sort -} -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} -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 -- cgit v0.12