merge trunk

9 files changed, 219 insertions, 51 deletions

diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index f5c8d41..d15ef3a 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -2229,7 +2229,7 @@ TclCompileTokens(
     Tcl_DString textBuffer;	/* Holds concatenated chars from adjacent
 				 * TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */
     char buffer[TCL_UTF_MAX];
-    int i, numObjsToConcat, length;
+    int i, numObjsToConcat, length, adjust;
     unsigned char *entryCodeNext = envPtr->codeNext;
 #define NUM_STATIC_POS 20
     int isLiteral, maxNumCL, numCL;
@@ -2266,6 +2266,7 @@ TclCompileTokens(
 	clPosition = ckalloc(maxNumCL * sizeof(int));
     }
 
+    adjust = 0;
     Tcl_DStringInit(&textBuffer);
     numObjsToConcat = 0;
     for ( ;  count > 0;  count--, tokenPtr++) {
@@ -2309,6 +2310,7 @@ TclCompileTokens(
 		    clPosition[numCL] = clPos;
 		    numCL ++;
 		}
+		adjust++;
 	    }
 	    break;
 
@@ -2331,8 +2333,10 @@ TclCompileTokens(
 		numCL = 0;
 	    }
 
+	    envPtr->line += adjust;
 	    TclCompileScript(interp, tokenPtr->start+1,
 		    tokenPtr->size-2, envPtr);
+	    envPtr->line -= adjust;
 	    numObjsToConcat++;
 	    break;
 
diff --git a/generic/tclEnv.c b/generic/tclEnv.c
index b5ae6ea..6a21947 100644
--- a/generic/tclEnv.c
+++ b/generic/tclEnv.c
@@ -76,36 +76,56 @@ TclSetupEnv(
     Tcl_Interp *interp)		/* Interpreter whose "env" array is to be
 				 * managed. */
 {
+    Var *varPtr, *arrayPtr;
+    Tcl_Obj *varNamePtr;
     Tcl_DString envString;
-    char *p1, *p2;
-    int i;
+    Tcl_HashTable namesHash;
+    Tcl_HashEntry *hPtr;
+    Tcl_HashSearch search;
 
     /*
      * Synchronize the values in the environ array with the contents of the
      * Tcl "env" variable. To do this:
-     *    1) Remove the trace that fires when the "env" var is unset.
-     *    2) Unset the "env" variable.
-     *    3) If there are no environ variables, create an empty "env" array.
-     *	     Otherwise populate the array with current values.
-     *    4) Add a trace that synchronizes the "env" array.
+     *    1) Remove the trace that fires when the "env" var is updated.
+     *    2) Find the existing contents of the "env", storing in a hash table.
+     *    3) Create/update elements for each environ variable, removing
+     *	     elements from the hash table as we go.
+     *    4) Remove the elements for each remaining entry in the hash table,
+     *	     which must have existed before yet have no analog in the environ
+     *	     variable.
+     *    5) Add a trace that synchronizes the "env" array.
      */
 
     Tcl_UntraceVar2(interp, "env", NULL,
 	    TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
 	    TCL_TRACE_READS | TCL_TRACE_ARRAY, EnvTraceProc, NULL);
 
-    Tcl_UnsetVar2(interp, "env", NULL, TCL_GLOBAL_ONLY);
+    /*
+     * Find out what elements are currently in the global env array.
+     */
 
-    if (environ[0] == NULL) {
-	Tcl_Obj *varNamePtr;
+    TclNewLiteralStringObj(varNamePtr, "env");
+    Tcl_IncrRefCount(varNamePtr);
+    Tcl_InitObjHashTable(&namesHash);
+    varPtr = TclObjLookupVarEx(interp, varNamePtr, NULL, TCL_GLOBAL_ONLY,
+	    /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
+    TclFindArrayPtrElements(varPtr, &namesHash);
+
+    /*
+     * Go through the environment array and transfer its values into Tcl. At
+     * the same time, remove those elements we add/update from the hash table
+     * of existing elements, so that after this part processes, that table
+     * will hold just the parts to remove.
+     */
+
+    if (environ[0] != NULL) {
+	int i;
 
-	TclNewLiteralStringObj(varNamePtr, "env");
-	Tcl_IncrRefCount(varNamePtr);
-	TclArraySet(interp, varNamePtr, NULL);
-	Tcl_DecrRefCount(varNamePtr);
-    } else {
 	Tcl_MutexLock(&envMutex);
 	for (i = 0; environ[i] != NULL; i++) {
+	    Tcl_Obj *obj1, *obj2;
+	    char *p1, *p2;
+
 	    p1 = Tcl_ExternalToUtfDString(NULL, environ[i], -1, &envString);
 	    p2 = strchr(p1, '=');
 	    if (p2 == NULL) {
@@ -119,12 +139,41 @@ TclSetupEnv(
 	    }
 	    p2++;
 	    p2[-1] = '\0';
-	    Tcl_SetVar2(interp, "env", p1, p2, TCL_GLOBAL_ONLY);
+	    obj1 = Tcl_NewStringObj(p1, -1);
+	    obj2 = Tcl_NewStringObj(p2, -1);
 	    Tcl_DStringFree(&envString);
+
+	    Tcl_IncrRefCount(obj1);
+	    Tcl_IncrRefCount(obj2);
+	    Tcl_ObjSetVar2(interp, varNamePtr, obj1, obj2, TCL_GLOBAL_ONLY);
+	    hPtr = Tcl_FindHashEntry(&namesHash, obj1);
+	    if (hPtr != NULL) {
+		Tcl_DeleteHashEntry(hPtr);
+	    }
+	    Tcl_DecrRefCount(obj1);
+	    Tcl_DecrRefCount(obj2);
 	}
 	Tcl_MutexUnlock(&envMutex);
     }
 
+    /*
+     * Delete those elements that existed in the array but which had no
+     * counterparts in the environment array.
+     */
+
+    for (hPtr=Tcl_FirstHashEntry(&namesHash, &search); hPtr!=NULL;
+	    hPtr=Tcl_NextHashEntry(&search)) {
+	Tcl_Obj *elemName = Tcl_GetHashValue(hPtr);
+
+	TclObjUnsetVar2(interp, varNamePtr, elemName, TCL_GLOBAL_ONLY);
+    }
+    Tcl_DeleteHashTable(&namesHash);
+    Tcl_DecrRefCount(varNamePtr);
+
+    /*
+     * Re-establish the trace.
+     */
+
     Tcl_TraceVar2(interp, "env", NULL,
 	    TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
 	    TCL_TRACE_READS | TCL_TRACE_ARRAY, EnvTraceProc, NULL);
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 46c1f77..55a5965 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3812,6 +3812,8 @@ MODULE_SCOPE int	TclPtrUnsetVar(Tcl_Interp *interp, Var *varPtr,
 			    Tcl_Obj *part2Ptr, const int flags,
 			    int index);
 MODULE_SCOPE void	TclInvalidateNsPath(Namespace *nsPtr);
+MODULE_SCOPE void	TclFindArrayPtrElements(Var *arrayPtr,
+			    Tcl_HashTable *tablePtr);
 
 /*
  * The new extended interface to the variable traces.
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 855e0dd..c5c7dc8 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -673,6 +673,10 @@ Tcl_CreateNamespace(
     Tcl_DString *namePtr, *buffPtr;
     int newEntry, nameLen;
     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+    const char *nameStr;
+    Tcl_DString tmpBuffer;
+
+    Tcl_DStringInit(&tmpBuffer);
 
     /*
      * If there is no active namespace, the interpreter is being initialized.
@@ -686,49 +690,78 @@ Tcl_CreateNamespace(
 
 	parentPtr = NULL;
 	simpleName = "";
-    } else if (*name == '\0') {
+	goto doCreate;
+    }
+
+    /*
+     * Ensure that there are no trailing colons as that causes chaos when a
+     * deleteProc is specified. [Bug d614d63989]
+     */
+
+    if (deleteProc != NULL) {
+	nameStr = name + strlen(name) - 2;
+	if (nameStr >= name && nameStr[1] == ':' && nameStr[0] == ':') {
+	    Tcl_DStringAppend(&tmpBuffer, name, -1);
+	    while ((nameLen = Tcl_DStringLength(&tmpBuffer)) > 0
+		    && Tcl_DStringValue(&tmpBuffer)[nameLen-1] == ':') {
+		Tcl_DStringSetLength(&tmpBuffer, nameLen-1);
+	    }
+	    name = Tcl_DStringValue(&tmpBuffer);
+	}
+    }
+
+    /*
+     * If we've ended up with an empty string now, we're attempting to create
+     * the global namespace despite the global namespace existing. That's
+     * naughty!
+     */
+
+    if (*name == '\0') {
 	Tcl_SetObjResult(interp, Tcl_NewStringObj("can't create namespace"
                 " \"\": only global namespace can have empty name", -1));
 	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE",
 		"CREATEGLOBAL", NULL);
+	Tcl_DStringFree(&tmpBuffer);
 	return NULL;
-    } else {
-	/*
-	 * Find the parent for the new namespace.
-	 */
+    }
+
+    /*
+     * Find the parent for the new namespace.
+     */
 
-	TclGetNamespaceForQualName(interp, name, NULL, TCL_CREATE_NS_IF_UNKNOWN,
-		&parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName);
+    TclGetNamespaceForQualName(interp, name, NULL, TCL_CREATE_NS_IF_UNKNOWN,
+	    &parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName);
 
-	/*
-	 * If the unqualified name at the end is empty, there were trailing
-	 * "::"s after the namespace's name which we ignore. The new namespace
-	 * was already (recursively) created and is pointed to by parentPtr.
-	 */
+    /*
+     * If the unqualified name at the end is empty, there were trailing "::"s
+     * after the namespace's name which we ignore. The new namespace was
+     * already (recursively) created and is pointed to by parentPtr.
+     */
 
-	if (*simpleName == '\0') {
-	    return (Tcl_Namespace *) parentPtr;
-	}
+    if (*simpleName == '\0') {
+	Tcl_DStringFree(&tmpBuffer);
+	return (Tcl_Namespace *) parentPtr;
+    }
 
-	/*
-	 * Check for a bad namespace name and make sure that the name does not
-	 * already exist in the parent namespace.
-	 */
+    /*
+     * Check for a bad namespace name and make sure that the name does not
+     * already exist in the parent namespace.
+     */
 
-	if (
+    if (
 #ifndef BREAK_NAMESPACE_COMPAT
-	    Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL
+	Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL
 #else
-	    parentPtr->childTablePtr != NULL &&
-	    Tcl_FindHashEntry(parentPtr->childTablePtr, simpleName) != NULL
+	parentPtr->childTablePtr != NULL &&
+	Tcl_FindHashEntry(parentPtr->childTablePtr, simpleName) != NULL
 #endif
-	) {
-	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
-                    "can't create namespace \"%s\": already exists", name));
-	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE",
-		    "CREATEEXISTING", NULL);
-	    return NULL;
-	}
+    ) {
+	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		"can't create namespace \"%s\": already exists", name));
+	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE",
+		"CREATEEXISTING", NULL);
+	Tcl_DStringFree(&tmpBuffer);
+	return NULL;
     }
 
     /*
@@ -736,6 +769,7 @@ Tcl_CreateNamespace(
      * of namespaces created.
      */
 
+  doCreate:
     nsPtr = ckalloc(sizeof(Namespace));
     nameLen = strlen(simpleName) + 1;
     nsPtr->name = ckalloc(nameLen);
@@ -831,6 +865,7 @@ Tcl_CreateNamespace(
 
     Tcl_DStringFree(&buffer1);
     Tcl_DStringFree(&buffer2);
+    Tcl_DStringFree(&tmpBuffer);
 
     /*
      * If compilation of commands originating from the parent NS is
diff --git a/generic/tclVar.c b/generic/tclVar.c
index e153fa4..65439ea 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -3706,6 +3706,53 @@ ArrayNamesCmd(
 /*
  *----------------------------------------------------------------------
  *
+ * TclFindArrayPtrElements --
+ *
+ *	Fill out a hash table (which *must* use Tcl_Obj* keys) with an entry
+ *	for each existing element of the given array. The provided hash table
+ *	is assumed to be initially empty.
+ *
+ * Result:
+ *	none
+ *
+ * Side effects:
+ *	The keys of the array gain an extra reference. The supplied hash table
+ *	has elements added to it.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclFindArrayPtrElements(
+    Var *arrayPtr,
+    Tcl_HashTable *tablePtr)
+{
+    Var *varPtr;
+    Tcl_HashSearch search;
+
+    if ((arrayPtr == NULL) || !TclIsVarArray(arrayPtr)
+	    || TclIsVarUndefined(arrayPtr)) {
+	return;
+    }
+
+    for (varPtr=VarHashFirstVar(arrayPtr->value.tablePtr, &search);
+	    varPtr!=NULL ; varPtr=VarHashNextVar(&search)) {
+	Tcl_HashEntry *hPtr;
+	Tcl_Obj *nameObj;
+	int dummy;
+
+	if (TclIsVarUndefined(varPtr)) {
+	    continue;
+	}
+	nameObj = VarHashGetKey(varPtr);
+	hPtr = Tcl_CreateHashEntry(tablePtr, (char *) nameObj, &dummy);
+	Tcl_SetHashValue(hPtr, nameObj);
+    }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * ArraySetCmd --
  *
  *	This object-based function is invoked to process the "array set" Tcl
diff --git a/tests/env.test b/tests/env.test
index fa76433..8115652 100644
--- a/tests/env.test
+++ b/tests/env.test
@@ -291,6 +291,29 @@ test env-6.1 {corner cases - add lots of env variables} {} {
     expr {[array size env] - $size}
 } 100
 
+test env-7.1 {[219226]: whole env array should not be unset by read} {
+    set n [array size env]
+    set s [array startsearch env]
+    while {[array anymore env $s]} {
+	array nextelement env $s
+	incr n -1
+    }
+    array donesearch env $s
+    return $n
+} 0
+test env-7.2 {[219226]: links to env elements should not be removed by read} {
+    apply {{} {
+	set ::env(test7_2) ok
+	upvar env(test7_2) elem
+	set ::env(PATH)
+	try {
+	    return $elem
+	} finally {
+	    unset ::env(test7_2)
+	}
+    }}
+} ok
+
 # Restore the environment variables at the end of the test.
 
 foreach name [array names env] {
diff --git a/tests/source.test b/tests/source.test
index d71212d..0235bd1 100644
--- a/tests/source.test
+++ b/tests/source.test
@@ -187,6 +187,16 @@ test source-3.5 {return with special code etc.} -setup {
     invoked from within
 "source $sourcefile"} {a b c}}
 
+test source-4.1 {continuation line parsing} -setup {
+    set sourcefile [makeFile [string map {CL \\\n} {
+	format %s "[dict get [info frame 0] type]:CL[dict get [info frame 0] line]CL[dict get [info frame 0] line]CL[dict get [info frame 0] line]"
+    }] source.file]
+} -body {
+    source $sourcefile
+} -cleanup {
+    removeFile source.file
+} -result {source: 3 4 5}
+
 test source-6.1 {source is binary ok} -setup {
     # Note [makeFile] writes in the system encoding.
     # [source] defaults to reading in the system encoding.
diff --git a/win/configure b/win/configure
index 3da29a8..59a3953 100755
--- a/win/configure
+++ b/win/configure
@@ -3450,7 +3450,7 @@ echo "${ECHO_T}yes" >&6
 
     if test "${GCC}" = "yes" ; then
 	extra_cflags="-pipe"
-	extra_ldflags="-pipe"
+	extra_ldflags="-pipe -static-libgcc"
 	echo "$as_me:$LINENO: checking for mingw32 version of gcc" >&5
 echo $ECHO_N "checking for mingw32 version of gcc... $ECHO_C" >&6
 if test "${ac_cv_win32+set}" = set; then
@@ -3579,7 +3579,6 @@ echo "${ECHO_T}$ac_cv_municode" >&6
 	    extra_ldflags="$extra_ldflags -municode"
 	else
 	    extra_cflags="$extra_cflags -DTCL_BROKEN_MAINARGS"
-	    extra_ldflags="$extra_ldflags -static-libgcc"
 	fi
     fi
 
diff --git a/win/tcl.m4 b/win/tcl.m4
index 6724ea9..71862fa 100644
--- a/win/tcl.m4
+++ b/win/tcl.m4
@@ -634,7 +634,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
 
     if test "${GCC}" = "yes" ; then
 	extra_cflags="-pipe"
-	extra_ldflags="-pipe"
+	extra_ldflags="-pipe -static-libgcc"
 	AC_CACHE_CHECK(for mingw32 version of gcc,
 	    ac_cv_win32,
 	    AC_TRY_COMPILE([
@@ -665,7 +665,6 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
 	    extra_ldflags="$extra_ldflags -municode"
 	else
 	    extra_cflags="$extra_cflags -DTCL_BROKEN_MAINARGS"
-	    extra_ldflags="$extra_ldflags -static-libgcc"
 	fi
     fi