diff options
Diffstat (limited to 'tests/stack.test')
| -rw-r--r-- | tests/stack.test | 88 |
1 files changed, 67 insertions, 21 deletions
diff --git a/tests/stack.test b/tests/stack.test index 9176201..62c3e98 100644 --- a/tests/stack.test +++ b/tests/stack.test @@ -8,13 +8,9 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: stack.test,v 1.9 2000/09/29 21:42:35 hobbs Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import -force ::tcltest::* -} +package require tcltest 2 +namespace import ::tcltest::* # Note that a failure in this test results in a crash of the executable. # In order to avoid that, we do a basic check of the current stacksize. @@ -23,28 +19,78 @@ if {[lsearch [namespace children] ::tcltest] == -1} { # This doesn't catch all cases, for example threads of lower stacksize # can still squeak through. A core check is really needed. -- JH -if {[string equal $::tcl_platform(platform) "unix"]} { +testConstraint minStack2034 1 +if {[testConstraint unix]} { set stackSize [exec /bin/sh -c "ulimit -s"] - if {[string is integer $stackSize] && ($stackSize < 2400)} { + if {[string is integer $stackSize] && ($stackSize < 2034)} { puts stderr "WARNING: the default application stacksize of $stackSize\ may cause Tcl to\ncrash due to stack overflow before the\ - recursion limit is reached.\nA minimum stacksize of 2400\ - kbytes is recommended.\nSkipping inifite recursion test." - set ::tcltest::testConstraints(minStack2400) 0 - } else { - set ::tcltest::testConstraints(minStack2400) 1 + recursion limit is reached.\nA minimum stacksize of 2034\ + kbytes is recommended.\nSkipping infinite recursion test." + testConstraint minStack2034 0 } -} else { - set ::tcltest::testConstraints(minStack2400) 1 } -test stack-1.1 {maxNestingDepth reached on infinite recursion} {minStack2400} { - proc recurse {} { return [recurse] } - catch {recurse} rv - rename recurse {} - set rv -} {too many nested calls to Tcl_EvalObj (infinite loop?)} +# +# Custom match to detect a stack overflow independently of the mechanism that +# triggered the error. +# + +customMatch stackOverflow StackOverflow +proc StackOverflow {- res} { + set msgList [list \ + "too many nested evaluations (infinite loop?)"\ + "out of stack space (infinite loop?)"] + expr {$res in $msgList} +} + +test stack-1.1 {maxNestingDepth reached on infinite recursion} -constraints { + minStack2034 +} -body { + # do this in a sub process in case it segfaults + exec [interpreter] << { + proc recurse {} { recurse } + catch { recurse } rv + puts $rv + } +} -match stackOverflow + +test stack-2.1 {maxNestingDepth reached on infinite recursion} -constraints { + minStack2034 +} -body { + # do this in a sub process in case it segfaults + exec [interpreter] << { + interp alias {} unknown {} notaknownproc + catch { unknown } msg + puts $msg + } +} -match stackOverflow + +# Make sure that there is enough stack to run regexp even if we're +# close to the recursion limit. [Bug 947070] [Patch 746378] +test stack-3.1 {enough room for regexp near recursion limit} -body { + # do this in a sub process in case it segfaults + exec [interpreter] << { + interp recursionlimit {} 10000 + set depth 0 + proc a { max } { + if { [info level] < $max } { + set ::depth [info level] + a $max + } else { + regexp {^ ?} x + } + } + catch { a 10001 } + set depth2 $depth + puts [list [a $depth] [expr { $depth2 - $depth }]] + } +} -result {1 1} # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: |