1# This file contains internal facilities for Tcl tests. 2# 3# Source this file in the related tests to include from tcl-tests: 4# 5# source [file join [file dirname [info script]] internals.tcl] 6# 7# Copyright © 2020 Sergey G. Brester (sebres). 8# 9# See the file "license.terms" for information on usage and redistribution 10# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 11 12if {[namespace which -command ::tcltest::internals::scriptpath] eq ""} {namespace eval ::tcltest::internals { 13 14namespace path ::tcltest 15 16::tcltest::ConstraintInitializer testWithLimit { expr {[testConstraint macOrUnix] && ![catch { exec prlimit --version }]} } 17 18# test-with-limit -- 19# 20# Usage: test-with-limit ?-addmem bytes? ?-maxmem bytes? command 21# Options: 22# -addmem - set additional memory limit (in bytes) as difference (extra memory needed to run a test) 23# -maxmem - set absolute maximum address space limit (in bytes) 24# 25proc testWithLimit args { 26 set body [lindex $args end] 27 array set in [lrange $args 0 end-1] 28 # test in child process (with limits): 29 set pipe {} 30 if {[catch { 31 # start new process: 32 set pipe [open |[list [interpreter]] r+] 33 set ppid [pid $pipe] 34 # create prlimit args: 35 set args {} 36 # with limited address space: 37 if {[info exists in(-addmem)] || [info exists in(-maxmem)]} { 38 if {[info exists in(-addmem)]} { 39 # as differnce to normal usage, so try to retrieve current memory usage: 40 if {[catch { 41 # using ps (vsz is in KB): 42 incr in(-addmem) [expr {[lindex [exec ps -hq $ppid -o vsz] end] * 1024}] 43 }]} { 44 # ps failed, use default size 20MB: 45 incr in(-addmem) 20000000 46 # + size of locale-archive (may be up to 100MB): 47 incr in(-addmem) [expr { 48 [file exists /usr/lib/locale/locale-archive] ? 49 [file size /usr/lib/locale/locale-archive] : 0 50 }] 51 } 52 if {![info exists in(-maxmem)]} { 53 set in(-maxmem) $in(-addmem) 54 } 55 set in(-maxmem) [expr { max($in(-addmem), $in(-maxmem)) }] 56 } 57 append args --as=$in(-maxmem) 58 } 59 # apply limits: 60 exec prlimit -p $ppid {*}$args 61 } msg opt]} { 62 catch {close $pipe} 63 tcltest::Warn "testWithLimit: error - [regsub {^\s*([^\n]*).*$} $msg {\1}]" 64 tcltest::Skip testWithLimit 65 } 66 # execute body, close process and return: 67 set ret [catch { 68 chan configure $pipe -buffering line 69 puts $pipe "puts \[$body\]" 70 puts $pipe exit 71 set result [read $pipe] 72 close $pipe 73 set pipe {} 74 set result 75 } result opt] 76 if {$pipe ne ""} { catch { close $pipe } } 77 if {$ret && [dict get $opt -errorcode] eq "BYPASS-SKIPPED-TEST"} { 78 return {*}$opt $result 79 } 80 if { ( [info exists in(-warn-on-code)] && $ret in $in(-warn-on-code) ) 81 || ( $ret && [info exists in(-warn-on-alloc-error)] && $in(-warn-on-alloc-error) 82 && [regexp {\munable to (?:re)?alloc\M} $result] ) 83 } { 84 tcltest::Warn "testWithLimit: wrong limit, result: $result" 85 tcltest::Skip testWithLimit 86 } 87 return {*}$opt $result 88} 89 90# export all routines starting with test 91namespace export test* 92 93# for script path & as mark for loaded 94proc scriptpath {} [list return [info script]] 95 96}}; # end of internals.