merge 8.7 (regression fix [e3f481f187], conflicts resolved)

5 files changed, 142 insertions, 69 deletions

diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 536180d..810b26e 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -3412,10 +3412,10 @@ TclPushVarName(
     int *isScalarPtr)		/* Must not be NULL. */
 {
     register const char *p;
-    const char *name, *elName;
-    register size_t i, n;
+    const char *last, *name, *elName;
+    register size_t n;
     Tcl_Token *elemTokenPtr = NULL;
-    size_t nameChars, elNameChars;
+	size_t nameLen, elNameLen;
     int simpleVarName, localIndex;
     int elemTokenCount = 0, allocedTokens = 0, removedParen = 0;
 
@@ -3429,7 +3429,7 @@ TclPushVarName(
 
     simpleVarName = 0;
     name = elName = NULL;
-    nameChars = elNameChars = 0;
+    nameLen = elNameLen = 0;
     localIndex = -1;
 
     if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
@@ -3441,22 +3441,25 @@ TclPushVarName(
 	simpleVarName = 1;
 
 	name = varTokenPtr[1].start;
-	nameChars = varTokenPtr[1].size;
-	if (name[nameChars-1] == ')') {
+	nameLen = varTokenPtr[1].size;
+	if (name[nameLen-1] == ')') {
 	    /*
 	     * last char is ')' => potential array reference.
 	     */
-
-	    for (i=0,p=name ; i<nameChars ; i++,p++) {
-		if (*p == '(') {
-		    elName = p + 1;
-		    elNameChars = nameChars - i - 2;
-		    nameChars = i;
-		    break;
+	    last = Tcl_UtfPrev(name + nameLen, name);
+
+	    if (*last == ')') {
+		for (p = name;  p < last;  p = Tcl_UtfNext(p)) {
+		    if (*p == '(') {
+			elName = p + 1;
+			elNameLen = last - elName;
+			nameLen = p - name;
+			break;
+		    }
 		}
 	    }
 
-	    if (!(flags & TCL_NO_ELEMENT) && (elName != NULL) && elNameChars) {
+	    if (!(flags & TCL_NO_ELEMENT) && elNameLen) {
 		/*
 		 * An array element, the element name is a simple string:
 		 * assemble the corresponding token.
@@ -3466,7 +3469,7 @@ TclPushVarName(
 		allocedTokens = 1;
 		elemTokenPtr->type = TCL_TOKEN_TEXT;
 		elemTokenPtr->start = elName;
-		elemTokenPtr->size = elNameChars;
+		elemTokenPtr->size = elNameLen;
 		elemTokenPtr->numComponents = 0;
 		elemTokenCount = 1;
 	    }
@@ -3474,21 +3477,22 @@ TclPushVarName(
     } else if (interp && ((n = varTokenPtr->numComponents) > 1)
 	    && (varTokenPtr[1].type == TCL_TOKEN_TEXT)
 	    && (varTokenPtr[n].type == TCL_TOKEN_TEXT)
-	    && (varTokenPtr[n].start[varTokenPtr[n].size - 1] == ')')) {
+	    && (*((p = varTokenPtr[n].start + varTokenPtr[n].size)-1) == ')')
+	    && (*Tcl_UtfPrev(p, varTokenPtr[n].start) == ')')) {
 	/*
 	 * Check for parentheses inside first token.
 	 */
 
 	simpleVarName = 0;
-	for (i = 0, p = varTokenPtr[1].start;
-		i < varTokenPtr[1].size; i++, p++) {
+	for (p = varTokenPtr[1].start,
+	     last = p + varTokenPtr[1].size;  p < last;  p = Tcl_UtfNext(p)) {
 	    if (*p == '(') {
 		simpleVarName = 1;
 		break;
 	    }
 	}
 	if (simpleVarName) {
-	    size_t remainingChars;
+	    size_t remainingLen;
 
 	    /*
 	     * Check the last token: if it is just ')', do not count it.
@@ -3504,13 +3508,13 @@ TclPushVarName(
 	    }
 
 	    name = varTokenPtr[1].start;
-	    nameChars = p - varTokenPtr[1].start;
+	    nameLen = p - varTokenPtr[1].start;
 	    elName = p + 1;
-	    remainingChars = (varTokenPtr[2].start - p) - 1;
-	    elNameChars = (varTokenPtr[n].start-p) + varTokenPtr[n].size - 1;
+	    remainingLen = (varTokenPtr[2].start - p) - 1;
+	    elNameLen = (varTokenPtr[n].start-p) + varTokenPtr[n].size - 1;
 
 	    if (!(flags & TCL_NO_ELEMENT)) {
-	      if (remainingChars) {
+	      if (remainingLen) {
 		/*
 		 * Make a first token with the extra characters in the first
 		 * token.
@@ -3520,7 +3524,7 @@ TclPushVarName(
 		allocedTokens = 1;
 		elemTokenPtr->type = TCL_TOKEN_TEXT;
 		elemTokenPtr->start = elName;
-		elemTokenPtr->size = remainingChars;
+		elemTokenPtr->size = remainingLen;
 		elemTokenPtr->numComponents = 0;
 		elemTokenCount = n;
 
@@ -3549,8 +3553,8 @@ TclPushVarName(
 
 	int hasNsQualifiers = 0;
 
-	for (i = 0, p = name;  i < nameChars;  i++, p++) {
-	    if ((*p == ':') && ((i+1) < nameChars) && (*(p+1) == ':')) {
+	for (p = name, last = p + nameLen-1;  p < last;  p = Tcl_UtfNext(p)) {
+	    if ((*p == ':') && (*(p+1) == ':')) {
 		hasNsQualifiers = 1;
 		break;
 	    }
@@ -3563,7 +3567,7 @@ TclPushVarName(
 	 */
 
 	if (!hasNsQualifiers) {
-	    localIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr);
+	    localIndex = TclFindCompiledLocal(name, nameLen, 1, envPtr);
 	    if ((flags & TCL_NO_LARGE_INDEX) && (localIndex > 255)) {
 		/*
 		 * We'll push the name.
@@ -3573,7 +3577,7 @@ TclPushVarName(
 	    }
 	}
 	if (interp && localIndex < 0) {
-	    PushLiteral(envPtr, name, nameChars);
+	    PushLiteral(envPtr, name, nameLen);
 	}
 
 	/*
@@ -3582,7 +3586,7 @@ TclPushVarName(
 	 */
 
 	if (elName != NULL && !(flags & TCL_NO_ELEMENT)) {
-	    if (elNameChars) {
+	    if (elNameLen) {
 		TclCompileTokens(interp, elemTokenPtr, elemTokenCount,
 			envPtr);
 	    } else {
diff --git a/generic/tclInt.h b/generic/tclInt.h
index ca50f33..3928cea 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -921,9 +921,8 @@ typedef struct CompiledLocal {
 				/* Next compiler-recognized local variable for
 				 * this procedure, or NULL if this is the last
 				 * local. */
-    int nameLength;		/* The number of characters in local
-				 * variable's name. Used to speed up variable
-				 * lookups. */
+    int nameLength;		/* The number of bytes in local variable's name.
+				 * Among others used to speed up var lookups. */
     int frameIndex;		/* Index in the array of compiler-assigned
 				 * variables in the procedure call frame. */
     int flags;			/* Flag bits for the local variable. Same as
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 0de0dd6..f4d2210 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -408,11 +408,8 @@ TclCreateProc(
 
     register Proc *procPtr = NULL;
     int i, result, numArgs;
-    size_t plen;
-    const char *bytes, *argname, *argnamei;
-    char argnamelast;
     register CompiledLocal *localPtr = NULL;
-    Tcl_Obj *defPtr, *errorObj, **argArray;
+    Tcl_Obj **argArray;
     int precompiled = 0;
 
     ProcGetIntRep(bodyPtr, procPtr);
@@ -449,6 +446,7 @@ TclCreateProc(
 	 */
 
 	if (Tcl_IsShared(bodyPtr)) {
+	    const char *bytes;
 	    size_t length;
 	    Tcl_Obj *sharedBodyPtr = bodyPtr;
 
@@ -511,8 +509,8 @@ TclCreateProc(
     }
 
     for (i = 0; i < numArgs; i++) {
+	const char *argname, *argnamei, *argnamelast;
 	int fieldCount, nameLength;
-	size_t valueLength;
 	Tcl_Obj **fieldValues;
 
 	/*
@@ -525,7 +523,7 @@ TclCreateProc(
 	    goto procError;
 	}
 	if (fieldCount > 2) {
-	    errorObj = Tcl_NewStringObj(
+	    Tcl_Obj *errorObj = Tcl_NewStringObj(
 		"too many fields in argument specifier \"", -1);
 	    Tcl_AppendObjToObj(errorObj, argArray[i]);
 	    Tcl_AppendToObj(errorObj, "\"", -1);
@@ -542,24 +540,17 @@ TclCreateProc(
 	    goto procError;
 	}
 
-	argname = TclGetStringFromObj(fieldValues[0], &plen);
-	nameLength = Tcl_NumUtfChars(argname, plen);
-	if (fieldCount == 2) {
-	    const char * value = TclGetString(fieldValues[1]);
-	    valueLength = Tcl_NumUtfChars(value, fieldValues[1]->length);
-	} else {
-	    valueLength = 0;
-	}
+	argname = TclGetStringFromObj(fieldValues[0], &nameLength);
 
 	/*
 	 * Check that the formal parameter name is a scalar.
 	 */
 
 	argnamei = argname;
-	argnamelast = argname[plen-1];
-	while (plen--) {
-	    if (argnamei[0] == '(') {
-		if (argnamelast == ')') {	/* We have an array element. */
+	argnamelast = Tcl_UtfPrev(argname + nameLength, argname);
+	while (argnamei < argnamelast) {
+	    if (*argnamei == '(') {
+		if (*argnamelast == ')') { /* We have an array element. */
 		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
 			    "formal parameter \"%s\" is an array element",
 			    Tcl_GetString(fieldValues[0])));
@@ -567,8 +558,9 @@ TclCreateProc(
 			    "FORMALARGUMENTFORMAT", NULL);
 		    goto procError;
 		}
-	    } else if ((argnamei[0] == ':') && (argnamei[1] == ':')) {
-		errorObj = Tcl_NewStringObj("formal parameter \"", -1);
+	    } else if (*argnamei == ':' && *(argnamei+1) == ':') {
+		Tcl_Obj *errorObj = Tcl_NewStringObj(
+		    "formal parameter \"", -1);
 		Tcl_AppendObjToObj(errorObj, fieldValues[0]);
 		Tcl_AppendToObj(errorObj, "\" is not a simple name", -1);
 		Tcl_SetObjResult(interp, errorObj);
@@ -592,7 +584,7 @@ TclCreateProc(
 	     */
 
 	    if ((localPtr->nameLength != nameLength)
-		    || (Tcl_UtfNcmp(localPtr->name, argname, nameLength))
+		    || (memcmp(localPtr->name, argname, nameLength) != 0)
 		    || (localPtr->frameIndex != i)
 		    || !(localPtr->flags & VAR_ARGUMENT)
 		    || (localPtr->defValuePtr == NULL && fieldCount == 2)
@@ -612,11 +604,14 @@ TclCreateProc(
 	    if (localPtr->defValuePtr != NULL) {
 		const char *tmpPtr = TclGetString(localPtr->defValuePtr);
 		size_t tmpLength = localPtr->defValuePtr->length;
-
-		if ((valueLength != tmpLength) ||
-			Tcl_UtfNcmp(Tcl_GetString(fieldValues[1]), tmpPtr, tmpLength)) {
-		    errorObj = Tcl_ObjPrintf(
-			    "procedure \"%s\": formal parameter \"" ,procName);
+		const char *value = TclGetString(fieldValues[1]);
+		size_t valueLength = fieldValues[1]->length;
+
+		if ((valueLength != tmpLength)
+		     || memcmp(value, tmpPtr, tmpLength) != 0
+		) {
+		    Tcl_Obj *errorObj = Tcl_ObjPrintf(
+			    "procedure \"%s\": formal parameter \"", procName);
 		    Tcl_AppendObjToObj(errorObj, fieldValues[0]);
 		    Tcl_AppendToObj(errorObj, "\" has "
 			"default value inconsistent with precompiled body", -1);
@@ -663,7 +658,7 @@ TclCreateProc(
 	    if ((i == numArgs - 1)
 		    && (localPtr->nameLength == 4)
 		    && (localPtr->name[0] == 'a')
-		    && (strcmp(localPtr->name, "args") == 0)) {
+		    && (memcmp(localPtr->name, "args", 4) == 0)) {
 		localPtr->flags |= VAR_IS_ARGS;
 	    }
 	}
@@ -681,9 +676,8 @@ TclCreateProc(
 	    localPtr = procPtr->firstLocalPtr;
 	    procPtr->firstLocalPtr = localPtr->nextPtr;
 
-	    defPtr = localPtr->defValuePtr;
-	    if (defPtr != NULL) {
-		Tcl_DecrRefCount(defPtr);
+	    if (localPtr->defValuePtr != NULL) {
+		Tcl_DecrRefCount(localPtr->defValuePtr);
 	    }
 
 	    Tcl_Free(localPtr);
diff --git a/tests/process.test b/tests/process.test
index 5aa8354..4c4bc99 100644
--- a/tests/process.test
+++ b/tests/process.test
@@ -14,12 +14,56 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
 }
 
 # Utilities
+file delete [set path(test-signalfile)  [makeFile {} test-signalfile]]
+set path(test-signalfile2) [makeFile {} test-signalfile2]
+# $path(sleep) time ?filename? -- sleep for time (in ms) and stop if it gets signaled (file gets deleted)
 set path(sleep) [makeFile {
-    after [expr $argv*1000]
+    after [expr {[lindex $argv 0]*1000}] {set stop 1}
+    if {[set fn [lindex $::argv 1]] ne ""} {
+	close [open $fn w]
+	proc check {} {
+	    if {![file exists $::fn]} { # exit signaled
+		after 10 {set ::stop 2}
+	    }
+	    after 10 check
+	}
+	after 10 check
+    }
+    vwait stop
     exit
 } sleep]
+
+proc wait_for_file {fn {timeout 10000}} {
+    if {![file exists $fn]} {
+	set toev [after $timeout {set found 0}]
+	proc check {fn} {
+	    if {[file exists $fn]} {
+		set ::found 1
+		return
+	    }
+	    after 10 [list check $fn]
+	}
+	after 10 [list check $fn]
+	vwait ::found
+	after cancel $toev
+	unset ::found
+    }
+    file exists $fn
+}
+proc signal_exit {fn {wait 1}} {
+    # wait for until file created if expected:
+    if {!$wait || [wait_for_file $fn]} {
+	# delete file to signal exit for child-process:
+	while {1} {
+	    if {![catch { file delete $fn } msg opt]
+		|| [lrange [dict get $opt -errorcode] 0 1] ne {POSIX EACCES}
+	    } break
+	}
+    }
+}
+
 set path(exit) [makeFile {
-    exit $argv
+    exit [lindex $argv 0]
 } exit]
 
 # Basic syntax checking
@@ -213,10 +257,13 @@ test process-5.3 {exec 3-stage pipe} -body {
 }
 
 # Async child status
-test process-6.1 {async status} -body {
+test process-6.1 {async status} -setup {
+    signal_exit $path(test-signalfile) 0; # clean signal-file
+} -body {
     tcl::process autopurge 0
-    set pid [exec [interpreter] $path(sleep) 1 &]
+    set pid [exec [interpreter] $path(sleep) 1 $path(test-signalfile) &]
     set status1 [lindex [tcl::process status $pid] 1]
+    signal_exit $path(test-signalfile); # signal exit (stop sleep)
     set status2 [lindex [tcl::process status -wait $pid] 1]
     expr {
            $status1 eq {}
@@ -226,19 +273,24 @@ test process-6.1 {async status} -body {
     tcl::process purge
     tcl::process autopurge 1
 }
-test process-6.2 {selective wait} -body {
+test process-6.2 {selective wait} -setup {
+    signal_exit $path(test-signalfile)  0; # clean signal-files
+    signal_exit $path(test-signalfile2) 0;
+} -body {
     tcl::process autopurge 0
     # Child 1 sleeps 1s
-    set pid1 [exec [interpreter] $path(sleep) 1 &]
+    set pid1 [exec [interpreter] $path(sleep) 1 $path(test-signalfile) &]
     # Child 2 sleeps 1s
-    set pid2 [exec [interpreter] $path(sleep) 2 &]
+    set pid2 [exec [interpreter] $path(sleep) 2 $path(test-signalfile2) &]
     # Initial status
     set status1_1 [lindex [tcl::process status $pid1] 1]
     set status1_2 [lindex [tcl::process status $pid2] 1]
     # Wait until child 1 termination
+    signal_exit $path(test-signalfile); # signal exit for pid1 (stop sleep)
     set status2_1 [lindex [tcl::process status -wait $pid1] 1]
     set status2_2 [lindex [tcl::process status $pid2] 1]
     # Wait until child 2 termination
+    signal_exit $path(test-signalfile2); # signal exit for pid2 (stop sleep)
     set status3_2 [lindex [tcl::process status -wait $pid2] 1]
     set status3_1 [lindex [tcl::process status $pid1] 1]
     expr {
@@ -280,5 +332,7 @@ test process-7.3 {child killed} -constraints {win} -body {
     tcl::process autopurge 1
 }
 
+rename wait_for_file {}
+rename signal_exit {}
 ::tcltest::cleanupTests
 return
diff --git a/tests/var.test b/tests/var.test
index 108c9ac..59f64ef 100644
--- a/tests/var.test
+++ b/tests/var.test
@@ -202,6 +202,28 @@ test var-1.18 {TclLookupVar, resurrect array element via upvar to deleted array:
 test var-1.19 {TclLookupVar, right error message when parsing variable name} -body {
     [format set] thisvar(doesntexist)
 } -returnCodes error -result {can't read "thisvar(doesntexist)": no such variable}
+test var-1.20 {TclLookupVar, regression on utf-8 variable names} -setup {
+    proc p [list \u20ac \xe4] {info vars}
+} -body {
+    # test variable with non-ascii name is available (euro and a-uml chars here):
+    list \
+	[p 1 2] \
+	[apply [list [list \u20ac \xe4] {info vars}] 1 2] \
+	[apply [list [list [list \u20ac \u20ac] [list \xe4 \xe4]] {info vars}]] \
+} -cleanup {
+    rename p {}
+} -result [lrepeat 3 [list \u20ac \xe4]]
+test var-1.21 {TclLookupVar, regression on utf-8 variable names} -setup {
+    proc p [list [list \u20ac v\u20ac] [list \xe4 v\xe4]] {list [set \u20ac] [set \xe4]}
+} -body {
+    # test variable with non-ascii name (and default) is resolvable (euro and a-uml chars here):
+    list \
+	[p] \
+	[apply [list [list \u20ac \xe4] {list [set \u20ac] [set \xe4]}] v\u20ac v\xe4] \
+	[apply [list [list [list \u20ac v\u20ac] [list \xe4 v\xe4]] {list [set \u20ac] [set \xe4]}]] \
+} -cleanup {
+    rename p {}
+} -result [lrepeat 3 [list v\u20ac v\xe4]]
 
 test var-2.1 {Tcl_LappendObjCmd, create var if new} {
     catch {unset x}