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.