sl@0: # Tests that the stack size is big enough for the application.
sl@0: #
sl@0: # This file contains a collection of tests for one or more of the Tcl
sl@0: # built-in commands.  Sourcing this file into Tcl runs the tests and
sl@0: # generates output for errors.  No output means no errors were found.
sl@0: #
sl@0: # Copyright (c) 1998-2000 Ajuba Solutions.
sl@0: # Portions Copyright (c) 2007 Nokia Corporation and/or its subsidiaries. All rights reserved. 
sl@0: #
sl@0: # See the file "license.terms" for information on usage and redistribution
sl@0: # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
sl@0: #
sl@0: # RCS: @(#) $Id: stack.test,v 1.15.2.1 2004/05/03 18:01:36 kennykb Exp $
sl@0: 
sl@0: if {[lsearch [namespace children] ::tcltest] == -1} {
sl@0:     package require tcltest 2
sl@0:     namespace import -force ::tcltest::*
sl@0: }
sl@0: 
sl@0: # Note that a failure in this test results in a crash of the executable.
sl@0: # In order to avoid that, we do a basic check of the current stacksize.
sl@0: # This size can be changed with ulimit (ksh/bash/sh) or limit (csh/tcsh).
sl@0: 
sl@0: # This doesn't catch all cases, for example threads of lower stacksize
sl@0: # can still squeak through.  A core check is really needed. -- JH
sl@0: 
sl@0: if {[string equal $::tcl_platform(platform) "unix"]} {
sl@0:     if {[string equal $tcl_platform(osSystemName) "Symbian"]} {
sl@0:     # cannot dynamically set stack size in Symbian, and max stack size is 80K in Symbian
sl@0:     set stackSize 80
sl@0:     } else {
sl@0:     set stackSize [exec /bin/sh -c "ulimit -s"] 
sl@0:     }
sl@0:     if {[string is integer $stackSize] && ($stackSize < 2400)} {
sl@0:         puts stderr "WARNING: the default application stacksize of $stackSize\
sl@0:                 may cause Tcl to\ncrash due to stack overflow before the\
sl@0:                 recursion limit is reached.\nA minimum stacksize of 2400\
sl@0:                 kbytes is recommended.\nSkipping infinite recursion test."
sl@0:         ::tcltest::testConstraint minStack2400 0
sl@0:     } else {
sl@0:         ::tcltest::testConstraint minStack2400 1
sl@0:     }
sl@0: } else {
sl@0:     ::tcltest::testConstraint minStack2400 1
sl@0: }
sl@0: 
sl@0: test stack-1.1 {maxNestingDepth reached on infinite recursion} {minStack2400} {
sl@0:     proc recurse {} { return [recurse] }
sl@0:     catch {recurse} rv
sl@0:     rename recurse {}
sl@0:     set rv
sl@0: } {too many nested evaluations (infinite loop?)}
sl@0: 
sl@0: test stack-2.1 {maxNestingDepth reached on infinite recursion} {minStack2400} {
sl@0:     # do this in a slave to not mess with parent
sl@0:     set slave stack-2.1
sl@0:     interp create $slave
sl@0:     $slave eval { interp alias {} unknown {} notaknownproc }
sl@0:     set msg [$slave eval { catch {foo} msg ; set msg }]
sl@0:     interp delete $slave
sl@0:     set msg
sl@0: } {too many nested evaluations (infinite loop?)}
sl@0: 
sl@0: # Make sure that there is enough stack to run regexp even if we're
sl@0: # close to the recursion limit. [Bug 947070]
sl@0: 
sl@0: test stack-3.1 {enough room for regexp near recursion limit} \
sl@0:     -constraints { win } \
sl@0:     -setup {
sl@0: 	set ::limit [interp recursionlimit {} 10000]
sl@0: 	set ::depth 0
sl@0: 	proc a { max } {
sl@0: 	    if { [info level] < $max } {
sl@0: 		set ::depth [info level]
sl@0: 		a $max
sl@0: 	    } else {
sl@0: 		regexp {^ ?} x
sl@0: 	    }
sl@0: 	}
sl@0: 	list [catch { a 10001 }]
sl@0: 	incr depth -3
sl@0: 	set depth2 $depth
sl@0:     } -body {
sl@0: 	list [catch { a $::depth } result] \
sl@0: 	    $result [expr { $::depth2 - $::depth }]
sl@0:     } -cleanup {
sl@0: 	interp recursionlimit {} $::limit
sl@0:     } -result {0 1 1}
sl@0: 
sl@0: # cleanup
sl@0: ::tcltest::cleanupTests
sl@0: return
sl@0: 
sl@0: # Local Variables:
sl@0: # mode: tcl
sl@0: # End: