Tcl Source Code

1999-04-06    <[email protected]>

	* generic/tclVar.c: 
	* generic/tclEnv.c: Moved the "array set" C level code into a
	common routine (TclArraySet).  The TclSetupEnv routine now uses
	this API to create an env array w/ no elements.

	* generic/tclEnv.c:
	* generic/tclWinInit.h:
	* generic/tclUnixInit.h:
	* generic/tclInt.h: Made the Env module I18N compliant.  Changed the
	FindVariable routine to TclpFindVariable, that now does a case
	insensitive string comparison on Windows, and not on UNIX. [Bug:
	1299, 1500]

1999-04-05    <[email protected]>

	* tests/io.test: Minor test cleanup.

	* generic/tclEncoding.c (Tcl_CreateEncoding): Minor lint to make
	it easier to compile on Digital-unix. [Bug: 1659]

Recent user-visible changes to Tcl:

RCS: @(#) $Id: changes,v 1.1.2.28 1999/04/06 19:06:51 surles Exp $

1. No more [command1] [command2] construct for grouping multiple
commands on a single command line.

2. Semi-colon now available for grouping commands on a line.

3. For a command to span multiple lines, must now use backslash-return

(redman)

4/5/99 (bug fix) Configure patches to improve support for
OS/390 and BSD/OS 4.*. (stanton)

4/5/99 (bug fix) Fixed crash in the clock command that occurred
with negative time values in timezones east of GMT. (stanton)

4/6/99 (bug fix) Moved the "array set" C level code into a common
routine (TclArraySet).  The TclSetupEnv routine now uses this API to
create an env array w/ no elements.  This fixes the bug caused when
every environ varaible is removed, and the Tcl env variable is
synched.  If no environ vars existed, the Tcl env var would never be
created. (surles)

4/6/99 (bug fix) Made the Env module I18N compliant. (surles)

4/6/99 (bug fix) Changed the FindVariable routine to TclpFindVariable,
that now does a case insensitive string comparison on Windows, and not
on UNIX. (surles)


--------------- Released 8.1b3, April 6, 1999 ----------------------

 *
 * Copyright (c) 1991-1994 The Regents of the University of California.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclEnv.c,v 1.1.2.6 1999/04/06 19:06:53 surles Exp $
 */

#include "tclInt.h"
#include "tclPort.h"

TCL_DECLARE_MUTEX(envMutex)	/* To serialize access to environ */

/*
 * Declarations for local procedures defined in this file:
 */

static char *		EnvTraceProc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, char *name1, char *name2,
			    int flags));


static void		ReplaceString _ANSI_ARGS_((CONST char *oldStr,
			    char *newStr));
void			TclSetEnv _ANSI_ARGS_((CONST char *name,
			    CONST char *value));
void			TclUnsetEnv _ANSI_ARGS_((CONST char *name));



 */

void
TclSetupEnv(interp)
    Tcl_Interp *interp;		/* Interpreter whose "env" array is to be
				 * managed. */
{
    Tcl_DString envString;
    char *p1, *p2;

    int i;

    /*
     * 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.
     */
    
    Tcl_UntraceVar2(interp, "env", (char *) NULL,
	    TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
	    TCL_TRACE_READS | TCL_TRACE_ARRAY,  EnvTraceProc,
	    (ClientData) NULL);
    
    Tcl_UnsetVar2(interp, "env", (char *) NULL, TCL_GLOBAL_ONLY); 
    
    if (environ[0] == NULL) {
	Tcl_Obj *varNamePtr;
	
	varNamePtr = Tcl_NewStringObj("env", -1);
	Tcl_IncrRefCount(varNamePtr);
	TclArraySet(interp, varNamePtr, NULL);	
	Tcl_DecrRefCount(varNamePtr);
    } else {
	Tcl_MutexLock(&envMutex);
	for (i = 0; environ[i] != NULL; i++) {
	    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; ignore the entry.
		 */
		
		continue;
	    }
	    p2++;
	    p2[-1] = '\0';
	    Tcl_SetVar2(interp, "env", p1, p2, TCL_GLOBAL_ONLY);	

	    Tcl_DStringFree(&envString);

	}
	Tcl_MutexUnlock(&envMutex);
    }

    Tcl_TraceVar2(interp, "env", (char *) NULL,
	    TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
	    TCL_TRACE_READS | TCL_TRACE_ARRAY,  EnvTraceProc,
	    (ClientData) NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * TclSetEnv --
 *

 *	The environ array gets updated.
 *
 *----------------------------------------------------------------------
 */

void
TclSetEnv(name, value)
    CONST char *name;		/* Name of variable whose value is to be
				 * set (UTF-8). */
    CONST char *value;		/* New value for variable (UTF-8). */
{
    Tcl_DString envString;
    int index, length, nameLength;
    char *p, *p2, *oldValue;

    /*
     * Figure out where the entry is going to go.  If the name doesn't
     * already exist, enlarge the array if necessary to make room.  If the
     * name exists, free its old entry.
     */

    Tcl_MutexLock(&envMutex);
    index = TclpFindVariable(name, &length);

    if (index == -1) {
#ifndef USE_PUTENV
	if ((length + 2) > environSize) {
	    char **newEnviron;

	    newEnviron = (char **) ckalloc((unsigned)
		    ((length + 5) * sizeof(char *)));

	}
	index = length;
	environ[index + 1] = NULL;
#endif
	oldValue = NULL;
	nameLength = strlen(name);
    } else {
	char *env;

	/*
	 * Compare the new value to the existing value.  If they're
	 * the same then quit immediately (e.g. don't rewrite the
	 * value or propagate it to other interpreters).  Otherwise,
	 * when there are N interpreters there will be N! propagations
	 * of the same value among the interpreters.
	 */

	env = Tcl_ExternalToUtfDString(NULL, environ[index], -1, &envString);
	if (strcmp(value, (env + length + 1)) == 0) {
	    Tcl_DStringFree(&envString);
	    Tcl_MutexUnlock(&envMutex);
	    return;
	}
	Tcl_DStringFree(&envString);

	oldValue = environ[index];
	nameLength = length;
    }
	

    /*
     * Create a new entry.  Build a complete UTF string that contains
     * a "name=value" pattern.  Then convert the string to the native
     * encoding, and set the environ array value.
     */

    p = (char *) ckalloc((unsigned) (nameLength + strlen(value) + 2));
    strcpy(p, name);
    p[nameLength] = '=';
    strcpy(p+nameLength+1, value);
    p2 = Tcl_UtfToExternalDString(NULL, p, -1, &envString);
    ckfree(p);
    

#ifdef USE_PUTENV
    /*
     * Update the system environment.
     */


    putenv(p2);
    index = TclpFindVariable(name, &length);
#else
    /*
     * Copy the native string to heap memory.
     */
    
    p = (char *) ckalloc((unsigned) (strlen(p2) + 1));
    strcpy(p, p2);
    environ[index] = p;
#endif

    /*
     * Watch out for versions of putenv that copy the string (e.g. VC++).
     * In this case we need to free the string immediately.  Otherwise
     * update the string in the cache.
     */

    if (environ[index] != p) {
	Tcl_DStringFree(&envString);
    } else {
	ReplaceString(oldValue, p);
    }

    Tcl_MutexUnlock(&envMutex);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PutEnv --

 */

int
Tcl_PutEnv(string)
    CONST char *string;		/* Info about environment variable in the
				 * form NAME=value. (native) */
{
    Tcl_DString nameString;   
    int nameLength;
    char *name, *value;

    if (string == NULL) {
	return 0;
    }

    /*
     * First convert the native string to UTF.  Then separate the
     * string into name and value parts, and call TclSetEnv to do
     * all of the real work.
     */

    name = Tcl_ExternalToUtfDString(NULL, string, -1, &nameString);
    value = strchr(name, '=');
    if (value == NULL) {
	return 0;
    }
    nameLength = value - name;
    if (nameLength == 0) {
	return 0;
    }


    value[0] = '\0';
    TclSetEnv(name, value+1);
    Tcl_DStringFree(&nameString);
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * TclUnsetEnv --

 *	Interpreters are updated, as is environ.
 *
 *----------------------------------------------------------------------
 */

void
TclUnsetEnv(name)
    CONST char *name;		/* Name of variable to remove (UTF-8). */
{
    char *oldValue;
    int length, index;
#ifdef USE_PUTENV
    Tcl_DString envString;
    char *string;
#else
    char **envPtr;
#endif

    Tcl_MutexLock(&envMutex);
    index = TclpFindVariable(name, &length);

    /*
     * First make sure that the environment variable exists to avoid
     * doing needless work and to avoid recursion on the unset.
     */
    
    if (index == -1) {

     */

#ifdef USE_PUTENV
    string = ckalloc(length+2);
    memcpy((VOID *) string, (VOID *) name, (size_t) length);
    string[length] = '=';
    string[length+1] = '\0';
    
    Tcl_UtfToExternalDString(NULL, string, -1, &envString);
    ckfree(string);
    string = Tcl_DStringValue(&envString);
    putenv(string);

    /*
     * Watch out for versions of putenv that copy the string (e.g. VC++).
     * In this case we need to free the string immediately.  Otherwise
     * update the string in the cache.
     */

    if (environ[index] != string) {
	Tcl_DStringFree(&envString);
    } else {
	ReplaceString(oldValue, string);
    }
#else
    for (envPtr = environ+index+1; ; envPtr++) {
	envPtr[-1] = *envPtr;
	if (*envPtr == NULL) {
	    break;
	}
    }






    ReplaceString(oldValue, NULL);
#endif

    Tcl_MutexUnlock(&envMutex);
}

/*
 *---------------------------------------------------------------------------
 *

    CONST char *name;		/* Name of environment variable to find
				 * (UTF-8). */
    Tcl_DString *valuePtr;	/* Uninitialized or free DString in which
				 * the value of the environment variable is
				 * stored. */
{
    int length, index;

    char *result;

    Tcl_MutexLock(&envMutex);
    index = TclpFindVariable(name, &length);
    result = NULL;
    if (index != -1) {
	Tcl_DString envStr;
	


	result = Tcl_ExternalToUtfDString(NULL, environ[index], -1, &envStr);
	result += length;
	if (*result == '=') {
	    result++;
	    Tcl_DStringInit(valuePtr);
	    Tcl_DStringAppend(valuePtr, result, -1);
	    result = Tcl_DStringValue(valuePtr);
	} else {
	    result = NULL;
	}
	Tcl_DStringFree(&envStr);
    }
    Tcl_MutexUnlock(&envMutex);
    return result;
}

/*
 *----------------------------------------------------------------------

    Tcl_Interp *interp;		/* Interpreter whose "env" variable is
				 * being modified. */
    char *name1;		/* Better be "env". */
    char *name2;		/* Name of variable being modified, or NULL
				 * if whole array is being deleted (UTF-8). */
    int flags;			/* Indicates what's happening. */
{
    /*
     * For array traces, let TclSetupEnv do all the work.
     */

    if (flags & TCL_TRACE_ARRAY) {
	TclSetupEnv(interp);
	return NULL;
    }

    /*
     * If name2 is NULL, then return and do nothing.
     */
     
    if (name2 == NULL) {
	return NULL;
    }

    /*
     * If a value is being set, call TclSetEnv to do all of the work.
     */

    if (flags & TCL_TRACE_WRITES) {

	char *value;
	
	value = Tcl_GetVar2(interp, "env", name2, TCL_GLOBAL_ONLY);


	TclSetEnv(name2, value);



    }

    /*
     * If a value is being read, call TclGetEnv to do all of the work.
     */

    if (flags & TCL_TRACE_READS) {
	Tcl_DString valueString;
	char *value;

	value = TclGetEnv(name2, &valueString);
	if (value == NULL) {
	    return "no such variable";
	}
	Tcl_SetVar2(interp, name1, name2, value, 0);
	Tcl_DStringFree(&valueString);
    }










    /*
     * For unset traces, let TclUnsetEnv do all the work.
     */

    if (flags & TCL_TRACE_UNSETS) {



	TclUnsetEnv(name2);

    }
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *

	}
	environCache = newCache;
	environCache[cacheSize] = (char *) newStr;
	environCache[cacheSize+1] = NULL;
	cacheSize += 5;
    }
}














































/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeEnvironment --
 *
 *	This function releases any storage allocated by this module

/*
 * tclInt.h --
 *
 *	Declarations of things used internally by the Tcl interpreter.
 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1993-1997 Lucent Technologies.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclInt.h,v 1.1.2.20 1999/04/06 19:06:53 surles Exp $
 */

#ifndef _TCLINT
#define _TCLINT

/*
 * Common include files needed by most of the Tcl source files are

 */

EXTERN int		TclAccess _ANSI_ARGS_((CONST char *path,
			    int mode));
EXTERN int		TclAccessDeleteProc _ANSI_ARGS_((TclAccessProc_ *proc));
EXTERN int		TclAccessInsertProc _ANSI_ARGS_((TclAccessProc_ *proc));
EXTERN void		TclAllocateFreeObjects _ANSI_ARGS_((void));
EXTERN int		TclArraySet _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj));
EXTERN int		TclCleanupChildren _ANSI_ARGS_((Tcl_Interp *interp,
			    int numPids, Tcl_Pid *pidPtr,
			    Tcl_Channel errorChan));
EXTERN void		TclCleanupCommand _ANSI_ARGS_((Command *cmdPtr));
EXTERN int		TclCopyChannel _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Channel inChan, Tcl_Channel outChan,
			    int toRead, Tcl_Obj *cmdPtr));

EXTERN void		TclpFinalizeMutex _ANSI_ARGS_((Tcl_Mutex *mutexPtr));
EXTERN void		TclpFinalizeThreadData _ANSI_ARGS_((
			    Tcl_ThreadDataKey *keyPtr));
EXTERN void		TclpFinalizeThreadDataKey _ANSI_ARGS_((
			    Tcl_ThreadDataKey *keyPtr));
EXTERN char *		TclpFindExecutable _ANSI_ARGS_((
			    CONST char *argv0));
EXTERN int		TclpFindVariable _ANSI_ARGS_((CONST char *name,
			    int *lengthPtr));
EXTERN void		TclpFree _ANSI_ARGS_((char *ptr));
EXTERN unsigned long	TclpGetClicks _ANSI_ARGS_((void));
EXTERN Tcl_Channel	TclpGetDefaultStdChannel _ANSI_ARGS_((int type));
EXTERN unsigned long	TclpGetSeconds _ANSI_ARGS_((void));
EXTERN void		TclpGetTime _ANSI_ARGS_((Tcl_Time *time));
EXTERN int		TclpGetTimeZone _ANSI_ARGS_((unsigned long time));
EXTERN char *		TclpGetUserHome _ANSI_ARGS_((CONST char *name,

 * Copyright (c) 1987-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclVar.c,v 1.1.2.5 1999/04/06 19:06:54 surles Exp $
 */

#include "tclInt.h"
#include "tclPort.h"

/*
 * The strings below are used to indicate what went wrong when a

     * below.
     */

    enum {ARRAY_ANYMORE, ARRAY_DONESEARCH,  ARRAY_EXISTS, ARRAY_GET,
	  ARRAY_NAMES, ARRAY_NEXTELEMENT, ARRAY_SET, ARRAY_SIZE,
	  ARRAY_STARTSEARCH}; 
    static char *arrayOptions[] = {"anymore", "donesearch", "exists",
				   "get", "names", "nextelement", "set",
				   "size", "startsearch", (char *) NULL};

    Interp *iPtr = (Interp *) interp;
    Var *varPtr, *arrayPtr;
    Tcl_HashEntry *hPtr;
    Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
    int notArray;
    char *varName, *msg;

		}
	    }
	    Tcl_SetStringObj(resultPtr,
	            Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), -1);
	    break;
	}
        case ARRAY_SET: {



	    if (objc != 4) {
	        Tcl_WrongNumArgs(interp, 2, objv, "arrayName list");
		return TCL_ERROR;
	    }













	    return(TclArraySet(interp, objv[2], objv[3]));














































	}
        case ARRAY_SIZE: {
	    Tcl_HashSearch search;
	    Var *varPtr2;
	    int size;

	    if (objc != 3) {

    return TCL_OK;

    error:
    Tcl_AppendStringsToObj(resultPtr, "\"", varName, "\" isn't an array",
	    (char *) NULL);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * TclArraySet --
 *
 *	Set the elements of an array.  If there are no elements to
 *	set, create an empty array.  This routine is used by the
 *	Tcl_ArrayObjCmd and by the TclSetupEnv routine.
 *
 * Results:
 *	A standard Tcl result object.
 *
 * Side effects:
 *	A variable will be created if one does not already exist.
 *
 *----------------------------------------------------------------------
 */

int
TclArraySet(interp, arrayNameObj, arrayElemObj)
    Tcl_Interp *interp;		/* Current interpreter. */
    Tcl_Obj *arrayNameObj;	/* The array name. */
    Tcl_Obj *arrayElemObj;	/* The array elements list.  If this is
				 * NULL, create an empty array. */
{
    Var *varPtr, *arrayPtr;
    Tcl_Obj **elemPtrs;
    int result, elemLen, i;
    char *varName;
    
    varName = TclGetString(arrayNameObj);
    varPtr = TclLookupVar(interp, varName, (char *) NULL, /*flags*/ 0,
            /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);

    if (arrayElemObj != NULL) {
	result = Tcl_ListObjGetElements(interp, arrayElemObj,
		&elemLen, &elemPtrs);
	if (result != TCL_OK) {
	    return result;
	}
	if (elemLen & 1) {
	    Tcl_ResetResult(interp);
	    Tcl_AppendToObj(Tcl_GetObjResult(interp),
		    "list must have an even number of elements", -1);
	    return TCL_ERROR;
	}
	if (elemLen > 0) {
	    for (i = 0;  i < elemLen;  i += 2) {
		if (Tcl_ObjSetVar2(interp, arrayNameObj, elemPtrs[i],
			elemPtrs[i+1], TCL_LEAVE_ERR_MSG) == NULL) {
		    result = TCL_ERROR;
		    break;
		}
	    }
	    return result;
	}
    }
    
    /*
     * The list is empty make sure we have an array, or create
     * one if necessary.
     */
    
    if (varPtr != NULL) {
	if (!TclIsVarUndefined(varPtr) && TclIsVarArray(varPtr)) {
	    /*
	     * Already an array, done.
	     */
	    
	    return TCL_OK;
	}
	if (TclIsVarArrayElement(varPtr) ||
		!TclIsVarUndefined(varPtr)) {
	    /*
	     * Either an array element, or a scalar: lose!
	     */
	    
	    VarErrMsg(interp, varName, (char *)NULL, "array set", needArray);
	    return TCL_ERROR;
	}
    } else {
	/*
	 * Create variable for new array.
	 */
	
	varPtr = TclLookupVar(interp, varName, (char *) NULL, 0, 0,
	        /*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr);
    }
    TclSetVarArray(varPtr);
    TclClearVarUndefined(varPtr);
    varPtr->value.tablePtr =
	(Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
    Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * MakeUpvar --
 *
 *	This procedure does all of the work of the "global" and "upvar"

# Commands covered:  none (tests environment variable implementation)
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: env.test,v 1.1.2.7 1999/04/06 19:06:56 surles Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

#
# These tests will run on any platform (and indeed crashed

test env-4.5 {unsetting international environment variables} {execCommandExists} {
    set env(\ub6) \ua7
    unset env(\ua7)
    set result [getenv]
    unset env(\ub6)
    set result
} "\ub6=\ua7"

test env-5.0 {corner cases - set a value, it should exist} {} {
    set temp [lindex [array names env] end]
    set x env($temp)
    set env($temp) a
    set result [set env($temp)]
    set env($temp) $x
    set result
} {a}
test env-5.1 {corner cases - remove one elem at a time} {} {
    # When no environment variables exist, the env var will
    # contain no entries.  The "array names" call synchs up
    # the C-level environ array with the Tcl level env array.
    # Make sure an empty Tcl array is created.

    set x [array get env]
    foreach e [array names env] {
	unset env($e)
    }
    set result [catch {array names env}]
    array set env $x
    set result
} {0}
test env-5.2 {corner cases - unset the env array} {} {
    # Unsetting a variable in an interp detaches the C-level
    # traces from the Tcl "env" variable.

    interp create i 
    i eval { unset env }
    i eval { set env(THIS_SHOULDNT_EXIST) a}
    set result [info exist env(THIS_SHOULDNT_EXIST)]
    interp delete i
    set result
} {0}
test env-5.3 {corner cases - unset the env in master should unset child} {} {
    # Variables deleted in a master interp should be deleted in
    # child interp too.

    interp create i 
    i eval { set env(THIS_SHOULD_EXIST) a}
    set result [set env(THIS_SHOULD_EXIST)]
    unset env(THIS_SHOULD_EXIST)
    lappend result [i eval {catch {set env(THIS_SHOULD_EXIST)}}]
    interp delete i
    set result
} {a 1}
test env-5.4 {corner cases - unset the env array} {} {
    # The info exist command should be in synch with the env array.

    interp create i 
    i eval { set env(THIS_SHOULD_EXIST) a}
    set     result [info exists env(THIS_SHOULD_EXIST)]
    lappend result [set env(THIS_SHOULD_EXIST)]
    lappend result [info exists env(THIS_SHOULD_EXIST)]
    interp delete i
    set result
} {1 a 1}
test env-5.5 {corner cases - cannot have null entries on Windows} {winOnly} {
    set env() a
    catch {set env()}
} {1}


# Restore the environment variables at the end of the test.

foreach name [array names env] {
    unset env($name)
}
foreach name [array names env2] {

/* 
 * tclUnixInit.c --
 *
 *	Contains the Unix-specific interpreter initialization functions.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUnixInit.c,v 1.1.2.13 1999/04/06 19:06:56 surles Exp $
 */

#include "tclInt.h"
#include "tclPort.h"
#include <locale.h>
#if defined(__FreeBSD__)
#   include <floatingpoint.h>

	    user = "";
	}
    }
    Tcl_SetVar2(interp, "tcl_platform", "user", user, TCL_GLOBAL_ONLY);
    Tcl_DStringFree(&ds);

}

/*
 *----------------------------------------------------------------------
 *
 * TclpFindVariable --
 *
 *	Locate the entry in environ for a given name.  On Unix this 
 *	routine is case sensetive, on Windows this matches mioxed case.
 *
 * Results:
 *	The return value is the index in environ of an entry with the
 *	name "name", or -1 if there is no such entry.   The integer at
 *	*lengthPtr is filled in with the length of name (if a matching
 *	entry is found) or the length of the environ array (if no matching
 *	entry is found).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclpFindVariable(name, lengthPtr)
    CONST char *name;		/* Name of desired environment variable
				 * (native). */
    int *lengthPtr;		/* Used to return length of name (for
				 * successful searches) or number of non-NULL
				 * entries in environ (for unsuccessful
				 * searches). */
{
    int i, result = -1;
    register CONST char *env, *p1, *p2;
    Tcl_DString envString;

    Tcl_DStringInit(&envString);
    for (i = 0, env = environ[i]; env != NULL; i++, env = environ[i]) {
	p1 = Tcl_ExternalToUtfDString(NULL, env, -1, &envString);
	p2 = name;

	for (; *p2 == *p1; p1++, p2++) {
	    /* NULL loop body. */
	}
	if ((*p1 == '=') && (*p2 == '\0')) {
	    *lengthPtr = p2 - name;
	    result = i;
	    goto done;
	}
	
	Tcl_DStringFree(&envString);
    }
    
    *lengthPtr = i;

    done:
    Tcl_DStringFree(&envString);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Init --
 *
 *	This procedure is typically invoked by Tcl_AppInit procedures

# Visual C++ 2.x and 4.0 makefile
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# RCS: @(#) $Id: makefile.vc,v 1.1.2.24 1999/04/06 19:06:57 surles Exp $

# Does not depend on the presence of any environment variables in
# order to compile tcl; all needed information is derived from 
# location of the compiler directories.

#
# Project directories

#	-DTCL_COMPILE_DEBUG	Enables byte compilation logging.
#	-DTCL_COMPILE_STATS	Enables byte compilation statistics gathering.
#	-DUSE_TCLALLOC=0	Disables the Tcl memory allocator in favor
#				of the native malloc implementation.  This is
#				needed when using Purify.
#
#DEBUGDEFINES = -DTCL_MEM_DEBUG -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS
DEBUGDEFINES = -DUSE_TCLALLOC=0

######################################################################
# Do not modify below this line
######################################################################

NAMEPREFIX = tcl
STUBPREFIX = $(NAMEPREFIX)stub

/* 
 * tclWinInit.c --
 *
 *	Contains the Windows-specific interpreter initialization functions.
 *
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinInit.c,v 1.1.2.9 1999/04/06 19:06:57 surles Exp $
 */

#include "tclWinInt.h"
#include <winreg.h>
#include <winnt.h>
#include <winbase.h>

	Tcl_SetVar2(interp, "tcl_platform", "user", Tcl_DStringValue(&ds),
		TCL_GLOBAL_ONLY);
    } else {
	Tcl_SetVar2(interp, "tcl_platform", "user", "", TCL_GLOBAL_ONLY);
    }
    Tcl_DStringFree(&ds);
}

/*
 *----------------------------------------------------------------------
 *
 * TclpFindVariable --
 *
 *	Locate the entry in environ for a given name.  On Unix this 
 *	routine is case sensetive, on Windows this matches mioxed case.
 *
 * Results:
 *	The return value is the index in environ of an entry with the
 *	name "name", or -1 if there is no such entry.   The integer at
 *	*lengthPtr is filled in with the length of name (if a matching
 *	entry is found) or the length of the environ array (if no matching
 *	entry is found).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclpFindVariable(name, lengthPtr)
    CONST char *name;		/* Name of desired environment variable
				 * (UTF-8). */
    int *lengthPtr;		/* Used to return length of name (for
				 * successful searches) or number of non-NULL
				 * entries in environ (for unsuccessful
				 * searches). */
{
    int i, length, result = -1;
    register CONST char *env, *p1, *p2;
    char *envUpper, *nameUpper;
    Tcl_DString envString;

    /*
     * Convert the name to all upper case for the case insensitive
     * comparison.
     */

    length = strlen(name);
    nameUpper = (char *) ckalloc((unsigned) length+1);
    memcpy((VOID *) nameUpper, (VOID *) name, (size_t) length+1);
    Tcl_UtfToUpper(nameUpper);
    
    Tcl_DStringInit(&envString);
    for (i = 0, env = environ[i]; env != NULL; i++, env = environ[i]) {
	/*
	 * Chop the env string off after the equal sign, then Convert
	 * the name to all upper case, so we do not have to convert
	 * all the characters after the equal sign.
	 */
	
	envUpper = Tcl_ExternalToUtfDString(NULL, env, -1, &envString);
	p1 = strchr(envUpper, '=');
	if (p1 == NULL) {
	    continue;
	}
	length = p1 - envUpper;
	Tcl_DStringSetLength(&envString, length+1);
	Tcl_UtfToUpper(envUpper);

	p1 = envUpper;
	p2 = nameUpper;
	for (; *p2 == *p1; p1++, p2++) {
	    /* NULL loop body. */
	}
	if ((*p1 == '=') && (*p2 == '\0')) {
	    *lengthPtr = length;
	    result = i;
	    goto done;
	}
	
	Tcl_DStringFree(&envString);
    }
    
    *lengthPtr = i;

    done:
    Tcl_DStringFree(&envString);
    ckfree(nameUpper);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Init --
 *
 *	This procedure is typically invoked by Tcl_AppInit procedures