Merge 8.5. Mark a few more tests nonPortable (for 8.5, not to be merged to 8.6!)

4 files changed, 68 insertions, 17 deletions

diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index eeee1b0..e8c3dd1 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -1218,12 +1218,32 @@ TclCompileScript(
     ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr;
     int *wlines, wlineat, cmdLine;
     int* clNext;
-    Tcl_Parse *parsePtr = (Tcl_Parse *)
-	    TclStackAlloc(interp, sizeof(Tcl_Parse));
+    Tcl_Parse *parsePtr;
 
     if (envPtr->iPtr == NULL) {
 	Tcl_Panic("TclCompileScript() called on uninitialized CompileEnv");
     }
+    /* 
+     * Check depth to avoid overflow of the C execution stack by too many
+     * nested calls of TclCompileScript (considering interp recursionlimit).
+     * Factor 5/4 (1.25) is used to avoid too mistaken limit recognition
+     * during "mixed" evaluation and compilation process (nested eval+compile)
+     * and is good enough for default recursionlimit (1000).
+     */
+    if (iPtr->numLevels / 5 > iPtr->maxNestingDepth / 4) {
+	Tcl_SetObjResult(interp, Tcl_NewStringObj(
+	    "too many nested compilations (infinite loop?)", -1));
+	Tcl_SetErrorCode(interp, "TCL", "LIMIT", "STACK", NULL);
+	TclCompileSyntaxError(interp, envPtr);
+	return;
+    }
+    /* 
+     * Avoid stack exhaustion by too many nested calls of TclCompileScript
+     * (considering interp recursionlimit).
+     */
+    iPtr->numLevels++;
+
+    parsePtr = (Tcl_Parse *)TclStackAlloc(interp, sizeof(Tcl_Parse));
 
     Tcl_DStringInit(&ds);
 
@@ -1631,6 +1651,7 @@ TclCompileScript(
 	TclEmitPush(TclAddLiteralObj(envPtr, Tcl_NewObj(), NULL), envPtr);
     }
 
+    iPtr->numLevels--;
     TclStackFree(interp, parsePtr);
     Tcl_DStringFree(&ds);
 }
diff --git a/tests/compile.test b/tests/compile.test
index a66da22..f027197 100644
--- a/tests/compile.test
+++ b/tests/compile.test
@@ -424,10 +424,13 @@ test compile-13.1 {testing underestimate of maxStackSize in list cmd} {exec} {
 
 # Tests of nested compile (body in body compilation), should not generate stack overflow
 # (with abnormal program termination), bug [fec0c17d39]:
-test compile-13.2 {TclCompileScript: testing nested scripts compilation} -setup {
-    set i [interp create]
-    interp recursionlimit $i [expr {10000+50}]
-    $i eval {proc gencode {nr {cmd eval} {nl 0}} {
+proc _ti_gencode {} {
+    # creates test interpreter on demand with [gencode] generator:
+    if {[interp exists ti]} {
+	return
+    }
+    interp create ti
+    ti eval {proc gencode {nr {cmd eval} {nl 0}} {
 	set code ""
 	set e ""; if {$nl} {set e "\n"}
 	for {set i 0} {$i < $nr} {incr i} {
@@ -440,18 +443,45 @@ test compile-13.2 {TclCompileScript: testing nested scripts compilation} -setup
 	#puts [format "%% %.40s ... %d bytes" $code [string length $code]]
 	return $code
     }}
+}
+test compile-13.2 {TclCompileScript: testing expected nested scripts compilation} -setup {
+    _ti_gencode
+    interp recursionlimit ti [expr {10000+50}]
+    ti eval {set result {}}
 } -body {
     # Test different compilation variants (instructions evalStk, invokeStk, etc),
-    # with 1500 (750 in debug) nested scripts (bodies). If you get SO/SF exceptions on some low-stack
+    # with 2000 (1000 in debug) nested scripts (bodies). If you get SO/SF exceptions on some low-stack
     # boxes or systems, please don't decrease it (either provide a constraint)
-    $i eval {foreach cmd {eval "if 1" catch} {
-	set c [gencode [expr {![::tcl::pkgconfig get debug] ? 1500 : 750}] $cmd]
+    ti eval {foreach cmd {eval "if 1" catch} {
+	set c [gencode [expr {![::tcl::pkgconfig get debug] ? 2000 : 1000}] $cmd]
 	if 1 $c
     }}
-    $i eval {set result}
-} -result {1 1 1} -cleanup {
-    interp delete $i
+    ti eval {set result}
+} -result {1 1 1}
+test compile-13.3 {TclCompileScript: testing check of max depth by nested scripts compilation} -setup {
+    _ti_gencode
+    interp recursionlimit ti 100
+    ti eval {set result {}}
+} -body {
+    # Test different compilation variants (instructions evalStk, invokeStk, etc),
+    # with 500 nested scripts (bodies). It must generate "too many nested compilations" 
+    # error for any variant we're testing here:
+    ti eval {foreach cmd {eval "if 1" catch} {
+	set c [gencode [expr {![info exists ::tcl_platform(debug)] ? 2000 : 1000}] $cmd]
+	lappend errors [catch $c e] $e
+    }}
+    #puts $errors
+    # all of nested calls exceed the limit, so must end with "too many nested compilations"
+    # (or evaluations, depending on compile method/instruction and "mixed" compile within 
+    # evaliation), so no one succeeds, the result must be empty:
+    ti eval {set result}
+} -result {}
+#
+# clean up:
+if {[interp exists ti]} {
+    interp delete ti
 }
+rename _ti_gencode {}
 
 # Tests compile-14.* for [Bug 599788] [Bug 0c043a175a47da8c2342]
 test compile-14.1 {testing errors in element name; segfault?} {} {
diff --git a/tests/fCmd.test b/tests/fCmd.test
index 71bc186..d79ac79 100644
--- a/tests/fCmd.test
+++ b/tests/fCmd.test
@@ -2551,7 +2551,7 @@ cd [workingDirectory]
 test fCmd-30.1 {file writable on 'My Documents'} -setup {
     # Get the localized version of the folder name by looking in the registry.
     set mydocsname [registry get {HKEY_CURRENT_USER\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders} Personal]
-} -constraints {win reg} -body {
+} -constraints {win reg nonPortable} -body {
     file writable $mydocsname
 } -result 1
 test fCmd-30.2 {file readable on 'NTUSER.DAT'} -constraints {win} -body {
diff --git a/tests/registry.test b/tests/registry.test
index 9691b3e..539ba2d 100644
--- a/tests/registry.test
+++ b/tests/registry.test
@@ -242,7 +242,7 @@ test registry-4.2 {GetKeyNames} {win reg} {
     registry delete HKEY_CURRENT_USER\\TclFoobar
     set result
 } {baz}
-test registry-4.3 {GetKeyNames: remote key} {win reg english} {
+test registry-4.3 {GetKeyNames: remote key} {win reg nonPortable english} {
     set hostname [info hostname]
     registry set \\\\$hostname\\HKEY_CURRENT_USER\\TclFoobar\\baz
     set result [registry keys \\\\gaspode\\HKEY_CURRENT_USER\\TclFoobar]
@@ -535,7 +535,7 @@ test registry-7.3 {GetValueNames} -constraints {win reg} -setup {
 } -cleanup {
     registry delete HKEY_CURRENT_USER\\TclFoobar
 } -result {{} baz blat}
-test registry-7.4 {GetValueNames: remote key} -constraints {win reg english} -body {
+test registry-7.4 {GetValueNames: remote key} -constraints {win reg nonPortable english} -body {
     set hostname [info hostname]
     registry set \\\\$hostname\\HKEY_CURRENT_USER\\TclFoobar baz blat
     set result [registry values \\\\$hostname\\HKEY_CURRENT_USER\\TclFoobar]
@@ -571,7 +571,7 @@ test registry-7.7 {GetValueNames: names with spaces} -constraints {win reg} -set
     registry delete HKEY_CURRENT_USER\\TclFoobar
 } -result {{baz bar} blat}
 
-test registry-8.1 {OpenSubKey} -constraints {win reg english} \
+test registry-8.1 {OpenSubKey} -constraints {win reg nonPortable english} \
     -body {
         # This test will only succeed if the current user does not have
         # registry access on the specified machine.
@@ -657,7 +657,7 @@ test registry-11.2 {SetValue: modification} -constraints {win reg} \
         set result [registry get HKEY_CURRENT_USER\\TclFoobar\\baz blat]
     } -result {frob}
 test registry-11.3 {SetValue: failure} \
-    -constraints {win reg english} \
+    -constraints {win reg nonPortable english} \
     -body {
         # This test will only succeed if the current user does not have
         # registry access on the specified machine.