diff options
author | surles <surles> | 1999-04-06 19:06:50 (GMT) |
---|---|---|
committer | surles <surles> | 1999-04-06 19:06:50 (GMT) |
commit | ffbe899b58d9f546a4174bb0c07f905248396274 (patch) | |
tree | 8e1793bd17e514a409f28db2e1f5d9b414dbc511 | |
parent | 514a36d57a5e7e39b5b972285a64aff469f8a561 (diff) | |
download | tcl-ffbe899b58d9f546a4174bb0c07f905248396274.zip tcl-ffbe899b58d9f546a4174bb0c07f905248396274.tar.gz tcl-ffbe899b58d9f546a4174bb0c07f905248396274.tar.bz2 |
* 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]
-rw-r--r-- | ChangeLog | 15 | ||||
-rw-r--r-- | changes | 16 | ||||
-rw-r--r-- | generic/tclEnv.c | 279 | ||||
-rw-r--r-- | generic/tclInt.h | 6 | ||||
-rw-r--r-- | generic/tclVar.c | 166 | ||||
-rw-r--r-- | tests/env.test | 64 | ||||
-rw-r--r-- | unix/tclUnixInit.c | 60 | ||||
-rw-r--r-- | win/makefile.vc | 4 | ||||
-rw-r--r-- | win/tclWinInit.c | 86 |
9 files changed, 485 insertions, 211 deletions
@@ -1,3 +1,18 @@ +1999-04-06 <surles@scriptics.com> + + * 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 <stanton@scriptics.com> * tests/io.test: Minor test cleanup. @@ -1,6 +1,6 @@ Recent user-visible changes to Tcl: -RCS: @(#) $Id: changes,v 1.1.2.27 1999/04/06 05:50:26 welch Exp $ +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. @@ -4291,5 +4291,19 @@ 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 ---------------------- diff --git a/generic/tclEnv.c b/generic/tclEnv.c index 2b64b1f..89484c4 100644 --- a/generic/tclEnv.c +++ b/generic/tclEnv.c @@ -12,7 +12,7 @@ * 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.5 1998/12/12 01:36:56 lfb Exp $ + * RCS: @(#) $Id: tclEnv.c,v 1.1.2.6 1999/04/06 19:06:53 surles Exp $ */ #include "tclInt.h" @@ -40,8 +40,6 @@ static int environSize = 0; /* Non-zero means that the environ array was static char * EnvTraceProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, char *name1, char *name2, int flags)); -static int FindVariable _ANSI_ARGS_((CONST char *name, - int *lengthPtr)); static void ReplaceString _ANSI_ARGS_((CONST char *oldStr, char *newStr)); void TclSetEnv _ANSI_ARGS_((CONST char *name, @@ -77,46 +75,59 @@ TclSetupEnv(interp) Tcl_Interp *interp; /* Interpreter whose "env" array is to be * managed. */ { - char *p, *p2; - Tcl_DString nameString, valueString; + Tcl_DString envString; + char *p1, *p2; int i; /* - * Store the environment variable values into the interpreter's - * "env" array, and arrange for us to be notified on future - * writes and unsets to that array. + * 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. */ - - (void) Tcl_UnsetVar2(interp, "env", (char *) NULL, TCL_GLOBAL_ONLY); - - Tcl_MutexLock(&envMutex); - for (i = 0; ; i++) { - p = environ[i]; - if (p == NULL) { - break; - } - p2 = strchr(p, '='); - if (p2 == NULL) { - /* - * This condition doesn't seem like it should ever happen, - * but it does seem to happen occasionally under some - * versions of Solaris; ignore the entry. - */ - - continue; + + 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_ExternalToUtfDString(NULL, p, p2 - p, &nameString); - Tcl_ExternalToUtfDString(NULL, p2 + 1, -1, &valueString); - Tcl_SetVar2(interp, "env", Tcl_DStringValue(&nameString), - Tcl_DStringValue(&valueString), TCL_GLOBAL_ONLY); - Tcl_DStringFree(&nameString); - Tcl_DStringFree(&valueString); + Tcl_MutexUnlock(&envMutex); } - 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); + TCL_TRACE_READS | TCL_TRACE_ARRAY, EnvTraceProc, + (ClientData) NULL); } /* @@ -142,12 +153,13 @@ TclSetupEnv(interp) void TclSetEnv(name, value) - CONST char *name; /* Nname of variable whose value is to be - * set (native). */ - CONST char *value; /* New value for variable (native). */ + 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, *oldValue; + char *p, *p2, *oldValue; /* * Figure out where the entry is going to go. If the name doesn't @@ -156,7 +168,8 @@ TclSetEnv(name, value) */ Tcl_MutexLock(&envMutex); - index = FindVariable(name, &length); + index = TclpFindVariable(name, &length); + if (index == -1) { #ifndef USE_PUTENV if ((length + 2) > environSize) { @@ -178,6 +191,8 @@ TclSetEnv(name, value) 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 @@ -186,32 +201,47 @@ TclSetEnv(name, value) * of the same value among the interpreters. */ - if (strcmp(value, environ[index] + length + 1) == 0) { + 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. + * 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. */ -#ifdef USE_PUTENV - putenv(p); - index = FindVariable(name, &length); + 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 @@ -222,10 +252,11 @@ TclSetEnv(name, value) */ if (environ[index] != p) { - ckfree(p); + Tcl_DStringFree(&envString); } else { ReplaceString(oldValue, p); } + Tcl_MutexUnlock(&envMutex); } @@ -257,6 +288,7 @@ Tcl_PutEnv(string) CONST char *string; /* Info about environment variable in the * form NAME=value. (native) */ { + Tcl_DString nameString; int nameLength; char *name, *value; @@ -265,23 +297,24 @@ Tcl_PutEnv(string) } /* - * Separate the string into name and value parts, then call - * TclSetEnv to do all of the real work. + * 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. */ - value = strchr(string, '='); + name = Tcl_ExternalToUtfDString(NULL, string, -1, &nameString); + value = strchr(name, '='); if (value == NULL) { return 0; } - nameLength = value - string; + nameLength = value - name; if (nameLength == 0) { return 0; } - name = (char *) ckalloc((unsigned) nameLength+1); - memcpy((VOID *) name, (VOID *) string, (size_t) nameLength); - name[nameLength] = 0; + + value[0] = '\0'; TclSetEnv(name, value+1); - ckfree(name); + Tcl_DStringFree(&nameString); return 0; } @@ -307,18 +340,19 @@ Tcl_PutEnv(string) void TclUnsetEnv(name) - CONST char *name; /* Name of variable to remove (native). */ + 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 = FindVariable(name, &length); + index = TclpFindVariable(name, &length); /* * First make sure that the environment variable exists to avoid @@ -345,8 +379,23 @@ TclUnsetEnv(name) memcpy((VOID *) string, (VOID *) name, (size_t) length); string[length] = '='; string[length+1] = '\0'; - putenv(string); + + 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; @@ -354,13 +403,8 @@ TclUnsetEnv(name) break; } } -#endif - - /* - * Replace the old value in the cache. - */ - ReplaceString(oldValue, NULL); +#endif Tcl_MutexUnlock(&envMutex); } @@ -394,19 +438,25 @@ TclGetEnv(name, valuePtr) * stored. */ { int length, index; - Tcl_DString nameString; char *result; Tcl_MutexLock(&envMutex); - Tcl_UtfToExternalDString(NULL, name, -1, &nameString); - - index = FindVariable(Tcl_DStringValue(&nameString), &length); - Tcl_DStringFree(&nameString); - + index = TclpFindVariable(name, &length); result = NULL; - if ((index != -1) && (*(environ[index]+length) == '=')) { - result = Tcl_ExternalToUtfDString(NULL, environ[index]+length+1, - -1, valuePtr); + 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; @@ -445,20 +495,31 @@ EnvTraceProc(clientData, interp, name1, name2, flags) 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) { - Tcl_DString nameString, valueString; char *value; value = Tcl_GetVar2(interp, "env", name2, TCL_GLOBAL_ONLY); - Tcl_UtfToExternalDString(NULL, name2, -1, &nameString); - Tcl_UtfToExternalDString(NULL, value, -1, &valueString); - TclSetEnv(Tcl_DStringValue(&nameString), - Tcl_DStringValue(&valueString)); - Tcl_DStringFree(&nameString); - Tcl_DStringFree(&valueString); + TclSetEnv(name2, value); } /* @@ -478,24 +539,11 @@ EnvTraceProc(clientData, interp, name1, name2, flags) } /* - * For array traces, let TclSetupEnv do all the work. - */ - - if (flags & TCL_TRACE_ARRAY) { - TclSetupEnv(interp); - } - - - /* * For unset traces, let TclUnsetEnv do all the work. */ - if ((flags & TCL_TRACE_UNSETS) && (name2 != NULL)) { - Tcl_DString nameString; - - Tcl_UtfToExternalDString(NULL, name2, -1, &nameString); - TclUnsetEnv(Tcl_DStringValue(&nameString)); - Tcl_DStringFree(&nameString); + if (flags & TCL_TRACE_UNSETS) { + TclUnsetEnv(name2); } return NULL; } @@ -580,51 +628,6 @@ ReplaceString(oldStr, newStr) /* *---------------------------------------------------------------------- * - * FindVariable -- - * - * Locate the entry in environ for a given name. - * - * 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. - * - *---------------------------------------------------------------------- - */ - -static int -FindVariable(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; - register CONST char *p1, *p2; - - for (i = 0, p1 = environ[i]; p1 != NULL; i++, p1 = environ[i]) { - for (p2 = name; *p2 == *p1; p1++, p2++) { - /* NULL loop body. */ - } - if ((*p1 == '=') && (*p2 == '\0')) { - *lengthPtr = p2-name; - return i; - } - } - *lengthPtr = i; - return -1; -} - -/* - *---------------------------------------------------------------------- - * * TclFinalizeEnvironment -- * * This function releases any storage allocated by this module diff --git a/generic/tclInt.h b/generic/tclInt.h index 6bb1042..c615d9d 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -11,7 +11,7 @@ * 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.19 1999/04/06 03:13:16 redman Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.1.2.20 1999/04/06 19:06:53 surles Exp $ */ #ifndef _TCLINT @@ -1556,6 +1556,8 @@ EXTERN int TclAccess _ANSI_ARGS_((CONST char *path, 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)); @@ -1725,6 +1727,8 @@ 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)); diff --git a/generic/tclVar.c b/generic/tclVar.c index ebf45f1..d63d20f 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -14,7 +14,7 @@ * 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.4 1999/02/10 23:31:20 stanton Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.1.2.5 1999/04/06 19:06:54 surles Exp $ */ #include "tclInt.h" @@ -2847,8 +2847,8 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) ARRAY_NAMES, ARRAY_NEXTELEMENT, ARRAY_SET, ARRAY_SIZE, ARRAY_STARTSEARCH}; static char *arrayOptions[] = {"anymore", "donesearch", "exists", - "get", "names", "nextelement", "set", "size", "startsearch", - (char *) NULL}; + "get", "names", "nextelement", "set", + "size", "startsearch", (char *) NULL}; Interp *iPtr = (Interp *) interp; Var *varPtr, *arrayPtr; @@ -3101,73 +3101,11 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) break; } case ARRAY_SET: { - Tcl_Obj **elemPtrs; - int listLen, i, result; - if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "arrayName list"); return TCL_ERROR; } - result = Tcl_ListObjGetElements(interp, objv[3], &listLen, - &elemPtrs); - if (result != TCL_OK) { - return result; - } - if (listLen & 1) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "list must have an even number of elements", -1); - return TCL_ERROR; - } - if (listLen > 0) { - for (i = 0; i < listLen; i += 2) { - if (Tcl_ObjSetVar2(interp, objv[2], 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; + return(TclArraySet(interp, objv[2], objv[3])); } case ARRAY_SIZE: { Tcl_HashSearch search; @@ -3235,6 +3173,102 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) /* *---------------------------------------------------------------------- * + * 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" diff --git a/tests/env.test b/tests/env.test index 2d1e2a7..fa2d86c 100644 --- a/tests/env.test +++ b/tests/env.test @@ -11,7 +11,7 @@ # 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.6 1999/03/24 02:49:04 hershey Exp $ +# 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] @@ -171,6 +171,68 @@ test env-4.5 {unsetting international environment variables} {execCommandExists} 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] { diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index 680d996..99651f7 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -8,7 +8,7 @@ * 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.12 1999/03/30 23:56:19 stanton Exp $ + * RCS: @(#) $Id: tclUnixInit.c,v 1.1.2.13 1999/04/06 19:06:56 surles Exp $ */ #include "tclInt.h" @@ -489,6 +489,64 @@ TclpSetVariables(interp) /* *---------------------------------------------------------------------- * + * 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 diff --git a/win/makefile.vc b/win/makefile.vc index 252627e..fc8df04 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -6,7 +6,7 @@ # Copyright (c) 1995-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # -# RCS: @(#) $Id: makefile.vc,v 1.1.2.23 1999/04/02 23:48:33 redman Exp $ +# 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 @@ -61,7 +61,7 @@ NODEBUG = 1 # needed when using Purify. # #DEBUGDEFINES = -DTCL_MEM_DEBUG -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS -#DEBUGDEFINES = -DUSE_TCLALLOC=0 +DEBUGDEFINES = -DUSE_TCLALLOC=0 ###################################################################### # Do not modify below this line diff --git a/win/tclWinInit.c b/win/tclWinInit.c index cc0bc85..b388557 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -9,7 +9,7 @@ * 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.8 1999/03/12 23:29:22 surles Exp $ + * RCS: @(#) $Id: tclWinInit.c,v 1.1.2.9 1999/04/06 19:06:57 surles Exp $ */ #include "tclWinInt.h" @@ -578,6 +578,90 @@ TclpSetVariables(interp) /* *---------------------------------------------------------------------- * + * 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 |