Tcl Source Code

    int count,			/* Number of tokens to consider at tokenPtr.
				 * Must be at least 1. */
    CompileEnv *envPtr)		/* Holds the resulting instructions. */
{
    Tcl_DString textBuffer;	/* Holds concatenated chars from adjacent
				 * TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */
    char buffer[TCL_UTF_MAX];
    int i, numObjsToConcat, length, adjust;
    unsigned char *entryCodeNext = envPtr->codeNext;
#define NUM_STATIC_POS 20
    int isLiteral, maxNumCL, numCL;
    int *clPosition = NULL;

    /*
     * For the handling of continuation lines in literals we first check if

    }

    if (isLiteral) {
	maxNumCL = NUM_STATIC_POS;
	clPosition = ckalloc(maxNumCL * sizeof(int));
    }

    adjust = 0;
    Tcl_DStringInit(&textBuffer);
    numObjsToConcat = 0;
    for ( ;  count > 0;  count--, tokenPtr++) {
	switch (tokenPtr->type) {
	case TCL_TOKEN_TEXT:
	    TclDStringAppendToken(&textBuffer, tokenPtr);
	    TclAdvanceLines(&envPtr->line, tokenPtr->start,

			maxNumCL *= 2;
			clPosition = ckrealloc(clPosition,
                                maxNumCL * sizeof(int));
		    }
		    clPosition[numCL] = clPos;
		    numCL ++;
		}
		adjust++;
	    }
	    break;

	case TCL_TOKEN_COMMAND:
	    /*
	     * Push any accumulated chars appearing before the command.
	     */

		if (numCL) {
		    TclContinuationsEnter(TclFetchLiteral(envPtr, literal),
			    numCL, clPosition);
		}
		numCL = 0;
	    }

	    envPtr->line += adjust;
	    TclCompileScript(interp, tokenPtr->start+1,
		    tokenPtr->size-2, envPtr);
	    envPtr->line -= adjust;
	    numObjsToConcat++;
	    break;

	case TCL_TOKEN_VARIABLE:
	    /*
	     * Push any accumulated chars appearing before the $<var>.
	     */

 */

void
TclSetupEnv(
    Tcl_Interp *interp)		/* Interpreter whose "env" array is to be
				 * managed. */
{
    Var *varPtr, *arrayPtr;
    Tcl_Obj *varNamePtr;
    Tcl_DString envString;

    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 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);


    /*


     * Find out what elements are currently in the global env array.
     */

    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;

	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) {
		/*
		 * This condition seem to happen occasionally under some
		 * versions of Solaris, or when encoding accidents swallow the
		 * '='; ignore the entry.
		 */

		continue;
	    }
	    p2++;
	    p2[-1] = '\0';
	    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);
}

/*
 *----------------------------------------------------------------------

MODULE_SCOPE int	TclPtrObjMakeUpvar(Tcl_Interp *interp, Var *otherPtr,
			    Tcl_Obj *myNamePtr, int myFlags, int index);
MODULE_SCOPE int	TclPtrUnsetVar(Tcl_Interp *interp, Var *varPtr,
			    Var *arrayPtr, Tcl_Obj *part1Ptr,
			    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.
 */

MODULE_SCOPE int	TclObjCallVarTraces(Interp *iPtr, Var *arrayPtr,
			    Var *varPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr,

    Namespace *globalNsPtr = iPtr->globalNsPtr;
    const char *simpleName;
    Tcl_HashEntry *entryPtr;
    Tcl_DString buffer1, buffer2;
    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.
     */

    if ((globalNsPtr == NULL) && (iPtr->varFramePtr == NULL)) {
	/*
	 * Treat this namespace as the global namespace, and avoid looking for
	 * a parent.
	 */

	parentPtr = NULL;
	simpleName = "";
	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;
    }

    /*
     * Find the parent for the new namespace.
     */

    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 (*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.
     */

    if (
#ifndef BREAK_NAMESPACE_COMPAT
	Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL
#else
	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);
	Tcl_DStringFree(&tmpBuffer);
	return NULL;

    }

    /*
     * Create the new namespace and root it in its parent. Increment the count
     * of namespaces created.
     */

  doCreate:
    nsPtr = ckalloc(sizeof(Namespace));
    nameLen = strlen(simpleName) + 1;
    nsPtr->name = ckalloc(nameLen);
    memcpy(nsPtr->name, simpleName, nameLen);
    nsPtr->fullName = NULL;		/* Set below. */
    nsPtr->clientData = clientData;
    nsPtr->deleteProc = deleteProc;

    name = Tcl_DStringValue(namePtr);
    nameLen = Tcl_DStringLength(namePtr);
    nsPtr->fullName = ckalloc(nameLen + 1);
    memcpy(nsPtr->fullName, name, (unsigned) nameLen + 1);

    Tcl_DStringFree(&buffer1);
    Tcl_DStringFree(&buffer2);
    Tcl_DStringFree(&tmpBuffer);

    /*
     * If compilation of commands originating from the parent NS is
     * suppressed, suppress it for commands originating in this one too.
     */

    if (nsPtr->parentPtr != NULL &&

	}

	Tcl_ListObjAppendElement(NULL, resultObj, nameObj);
    }
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * 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

test env-6.1 {corner cases - add lots of env variables} {} {
    set size [array size env]
    for {set i 0} {$i < 100} {incr i} {
	set env(BOGUS$i) $i
    }
    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] {
    unset env($name)
}
array set env $env2

} -body {
    list [catch {source $sourcefile} msg] $msg $::errorInfo $::errorCode
} -cleanup {
    removeFile source.file
} -result {1 {} {Simulated errorInfo stuff
    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.
    set sourcefile [makeFile [list set x "a b\0c"] source.file]
} -body {
    set x {}

        DEPARG='"$(shell $(CYGPATH) $<)"'
    fi

    # set various compiler flags depending on whether we are using gcc or cl

    if test "${GCC}" = "yes" ; then
	extra_cflags="-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
  echo $ECHO_N "(cached) $ECHO_C" >&6
else
  cat >conftest.$ac_ext <<_ACEOF
/* confdefs.h.  */

echo "$as_me:$LINENO: result: $ac_cv_municode" >&5
echo "${ECHO_T}$ac_cv_municode" >&6
	CFLAGS=$hold_cflags
	if test "$ac_cv_municode" = "yes" ; then
	    extra_ldflags="$extra_ldflags -municode"
	else
	    extra_cflags="$extra_cflags -DTCL_BROKEN_MAINARGS"

	fi
    fi

    echo "$as_me:$LINENO: checking compiler flags" >&5
echo $ECHO_N "checking compiler flags... $ECHO_C" >&6
    if test "${GCC}" = "yes" ; then
	SHLIB_LD=""

        DEPARG='"$(shell $(CYGPATH) $<)"'
    fi

    # set various compiler flags depending on whether we are using gcc or cl

    if test "${GCC}" = "yes" ; then
	extra_cflags="-pipe"
	extra_ldflags="-pipe -static-libgcc"
	AC_CACHE_CHECK(for mingw32 version of gcc,
	    ac_cv_win32,
	    AC_TRY_COMPILE([
		#ifdef __WIN32__
		    #error win32
		#endif
	    ], [],

	    ac_cv_municode=no)
	)
	CFLAGS=$hold_cflags
	if test "$ac_cv_municode" = "yes" ; then
	    extra_ldflags="$extra_ldflags -municode"
	else
	    extra_cflags="$extra_cflags -DTCL_BROKEN_MAINARGS"

	fi
    fi

    AC_MSG_CHECKING([compiler flags])
    if test "${GCC}" = "yes" ; then
	SHLIB_LD=""
	SHLIB_LD_LIBS='${LIBS}'