diff options
Diffstat (limited to 'win/tclWinInit.c')
| -rw-r--r-- | win/tclWinInit.c | 807 |
1 files changed, 566 insertions, 241 deletions
diff --git a/win/tclWinInit.c b/win/tclWinInit.c index ef6eaecc..8b600f6 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -1,36 +1,33 @@ -/* +/* * tclWinInit.c -- * * Contains the Windows-specific interpreter initialization functions. * - * Copyright (c) 1994-1996 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright (c) 1998-1999 by Scriptics Corporation. + * All rights reserved. * - * RCS: @(#) $Id: tclWinInit.c,v 1.11 1998/10/20 17:27:47 suresh Exp $ + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#include "tclInt.h" -#include "tclPort.h" -#include <winreg.h> +#include "tclWinInt.h" #include <winnt.h> #include <winbase.h> +#include <lmcons.h> /* - * The following macro can be defined at compile time to specify - * the root of the Tcl registry keys. + * GetUserName() is found in advapi32.dll */ - -#ifndef TCL_REGISTRY_KEY -#define TCL_REGISTRY_KEY "Software\\Scriptics\\Tcl\\" TCL_VERSION +#ifdef _MSC_VER +# pragma comment(lib, "advapi32.lib") #endif /* * The following declaration is a workaround for some Microsoft brain damage. * The SYSTEM_INFO structure is different in various releases, even though the - * layout is the same. So we overlay our own structure on top of it so we - * can access the interesting slots in a uniform way. + * layout is the same. So we overlay our own structure on top of it so we can + * access the interesting slots in a uniform way. */ typedef struct { @@ -43,19 +40,40 @@ typedef struct { */ #ifndef PROCESSOR_ARCHITECTURE_INTEL -#define PROCESSOR_ARCHITECTURE_INTEL 0 +#define PROCESSOR_ARCHITECTURE_INTEL 0 #endif #ifndef PROCESSOR_ARCHITECTURE_MIPS -#define PROCESSOR_ARCHITECTURE_MIPS 1 +#define PROCESSOR_ARCHITECTURE_MIPS 1 #endif #ifndef PROCESSOR_ARCHITECTURE_ALPHA -#define PROCESSOR_ARCHITECTURE_ALPHA 2 +#define PROCESSOR_ARCHITECTURE_ALPHA 2 #endif #ifndef PROCESSOR_ARCHITECTURE_PPC -#define PROCESSOR_ARCHITECTURE_PPC 3 +#define PROCESSOR_ARCHITECTURE_PPC 3 +#endif +#ifndef PROCESSOR_ARCHITECTURE_SHX +#define PROCESSOR_ARCHITECTURE_SHX 4 +#endif +#ifndef PROCESSOR_ARCHITECTURE_ARM +#define PROCESSOR_ARCHITECTURE_ARM 5 +#endif +#ifndef PROCESSOR_ARCHITECTURE_IA64 +#define PROCESSOR_ARCHITECTURE_IA64 6 +#endif +#ifndef PROCESSOR_ARCHITECTURE_ALPHA64 +#define PROCESSOR_ARCHITECTURE_ALPHA64 7 +#endif +#ifndef PROCESSOR_ARCHITECTURE_MSIL +#define PROCESSOR_ARCHITECTURE_MSIL 8 +#endif +#ifndef PROCESSOR_ARCHITECTURE_AMD64 +#define PROCESSOR_ARCHITECTURE_AMD64 9 +#endif +#ifndef PROCESSOR_ARCHITECTURE_IA32_ON_WIN64 +#define PROCESSOR_ARCHITECTURE_IA32_ON_WIN64 10 #endif #ifndef PROCESSOR_ARCHITECTURE_UNKNOWN -#define PROCESSOR_ARCHITECTURE_UNKNOWN 0xFFFF +#define PROCESSOR_ARCHITECTURE_UNKNOWN 0xFFFF #endif /* @@ -64,163 +82,473 @@ typedef struct { */ -#define NUMPLATFORMS 3 -static char* platforms[NUMPLATFORMS] = { - "Win32s", "Windows 95", "Windows NT" +#define NUMPLATFORMS 4 +static const char *const platforms[NUMPLATFORMS] = { + "Win32s", "Windows 95", "Windows NT", "Windows CE" }; -#define NUMPROCESSORS 4 -static char* processors[NUMPROCESSORS] = { - "intel", "mips", "alpha", "ppc" +#define NUMPROCESSORS 11 +static const char *const processors[NUMPROCESSORS] = { + "intel", "mips", "alpha", "ppc", "shx", "arm", "ia64", "alpha64", "msil", + "amd64", "ia32_on_win64" }; /* - * The Init script, tclPreInitScript variable, and the routine - * TclSetPreInitScript (common to Windows and Unix platforms) are defined - * in generic/tclInitScript.h + * The default directory in which the init.tcl file is expected to be found. */ -#include "tclInitScript.h" +static TclInitProcessGlobalValueProc InitializeDefaultLibraryDir; +static ProcessGlobalValue defaultLibraryDir = + {0, 0, NULL, NULL, InitializeDefaultLibraryDir, NULL, NULL}; + +static TclInitProcessGlobalValueProc InitializeSourceLibraryDir; +static ProcessGlobalValue sourceLibraryDir = + {0, 0, NULL, NULL, InitializeSourceLibraryDir, NULL, NULL}; +static void AppendEnvironment(Tcl_Obj *listPtr, const char *lib); +static int ToUtf(const WCHAR *wSrc, char *dst); /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- + * + * TclpInitPlatform -- * - * TclPlatformInit -- + * Initialize all the platform-dependant things like signals, + * floating-point error handling and sockets. * - * Performs Windows-specific interpreter initialization related to the - * tcl_library variable. Also sets up the HOME environment variable - * if it is not already set. + * Called at process initialization time. * * Results: * None. * * Side effects: - * Sets "tcl_library" and "env(HOME)" Tcl variables + * None. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ void -TclPlatformInit(interp) - Tcl_Interp *interp; +TclpInitPlatform(void) { - char *p; - char buffer[13]; - Tcl_DString ds; - OSVERSIONINFO osInfo; - SYSTEM_INFO sysInfo; - int isWin32s; /* True if we are running under Win32s. */ - OemId *oemId; - HKEY key; - DWORD size, result, type; + WSADATA wsaData; + WORD wVersionRequested = MAKEWORD(2, 2); tclPlatform = TCL_PLATFORM_WINDOWS; - Tcl_DStringInit(&ds); + /* + * Initialize the winsock library. On Windows XP and higher this + * can never fail. + */ + WSAStartup(wVersionRequested, &wsaData); + +#ifdef STATIC_BUILD + /* + * If we are in a statically linked executable, then we need to explicitly + * initialize the Windows function tables here since DllMain() will not be + * invoked. + */ + + TclWinInit(GetModuleHandle(NULL)); +#endif +} + +/* + *------------------------------------------------------------------------- + * + * TclpInitLibraryPath -- + * + * This is the fallback routine that sets the library path if the + * application has not set one by the first time it is needed. + * + * Results: + * None. + * + * Side effects: + * Sets the library path to an initial value. + * + *------------------------------------------------------------------------- + */ + +void +TclpInitLibraryPath( + char **valuePtr, + int *lengthPtr, + Tcl_Encoding *encodingPtr) +{ +#define LIBRARY_SIZE 64 + Tcl_Obj *pathPtr; + char installLib[LIBRARY_SIZE]; + const char *bytes; + + pathPtr = Tcl_NewObj(); /* - * Find out what kind of system we are running on. + * Initialize the substring used when locating the script library. The + * installLib variable computes the script library path relative to the + * installed DLL. */ - osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFO); - GetVersionEx(&osInfo); + sprintf(installLib, "lib/tcl%s", TCL_VERSION); + + /* + * Look for the library relative to the TCL_LIBRARY env variable. If the + * last dirname in the TCL_LIBRARY path does not match the last dirname in + * the installLib variable, use the last dir name of installLib in + * addition to the orginal TCL_LIBRARY path. + */ - isWin32s = (osInfo.dwPlatformId == VER_PLATFORM_WIN32s); + AppendEnvironment(pathPtr, installLib); /* - * Since Win32s doesn't support GetSystemInfo, we use a default value. + * Look for the library in its default location. */ - oemId = (OemId *) &sysInfo; - if (!isWin32s) { - GetSystemInfo(&sysInfo); - } else { - oemId->wProcessorArchitecture = PROCESSOR_ARCHITECTURE_INTEL; + Tcl_ListObjAppendElement(NULL, pathPtr, + TclGetProcessGlobalValue(&defaultLibraryDir)); + + /* + * Look for the library in its source checkout location. + */ + + Tcl_ListObjAppendElement(NULL, pathPtr, + TclGetProcessGlobalValue(&sourceLibraryDir)); + + *encodingPtr = NULL; + bytes = Tcl_GetStringFromObj(pathPtr, lengthPtr); + *valuePtr = ckalloc((*lengthPtr) + 1); + memcpy(*valuePtr, bytes, (size_t)(*lengthPtr)+1); + Tcl_DecrRefCount(pathPtr); +} + +/* + *--------------------------------------------------------------------------- + * + * AppendEnvironment -- + * + * Append the value of the TCL_LIBRARY environment variable onto the path + * pointer. If the env variable points to another version of tcl (e.g. + * "tcl7.6") also append the path to this version (e.g., + * "tcl7.6/../tcl8.2") + * + * Results: + * None. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +static void +AppendEnvironment( + Tcl_Obj *pathPtr, + const char *lib) +{ + int pathc; + WCHAR wBuf[MAX_PATH]; + char buf[MAX_PATH * TCL_UTF_MAX]; + Tcl_Obj *objPtr; + Tcl_DString ds; + const char **pathv; + char *shortlib; + + /* + * The shortlib value needs to be the tail component of the lib path. For + * example, "lib/tcl8.4" -> "tcl8.4" while "usr/share/tcl8.5" -> "tcl8.5". + */ + + for (shortlib = (char *) &lib[strlen(lib)-1]; shortlib>lib ; shortlib--) { + if (*shortlib == '/') { + if ((unsigned)(shortlib - lib) == strlen(lib) - 1) { + Tcl_Panic("last character in lib cannot be '/'"); + } + shortlib++; + break; + } + } + if (shortlib == lib) { + Tcl_Panic("no '/' character found in lib"); } /* - * Initialize the tcl_library variable from the registry. + * The "L" preceeding the TCL_LIBRARY string is used to tell VC++ that + * this is a unicode string. */ - Tcl_SetVar(interp, "tclDefaultLibrary", "", TCL_GLOBAL_ONLY); - if (!isWin32s) { - result = RegOpenKeyEx(HKEY_LOCAL_MACHINE, TCL_REGISTRY_KEY, 0, - KEY_READ, &key); + if (GetEnvironmentVariableW(L"TCL_LIBRARY", wBuf, MAX_PATH) == 0) { + buf[0] = '\0'; + GetEnvironmentVariableA("TCL_LIBRARY", buf, MAX_PATH); } else { - result = RegOpenKeyEx(HKEY_CLASSES_ROOT, TCL_REGISTRY_KEY, 0, - KEY_READ, &key); + ToUtf(wBuf, buf); } - if (result == ERROR_SUCCESS) { - if (RegQueryValueEx(key, "", NULL, NULL, NULL, &size) - == ERROR_SUCCESS) { - char *argv[3]; - Tcl_DStringSetLength(&ds, size); - RegQueryValueEx(key, "", NULL, NULL, - (LPBYTE) Tcl_DStringValue(&ds), &size); - Tcl_SetVar(interp, "tclDefaultLibrary", Tcl_DStringValue(&ds), - TCL_GLOBAL_ONLY); - argv[0] = Tcl_GetVar(interp, "tclDefaultLibrary", TCL_GLOBAL_ONLY); - argv[1] = "lib/tcl" TCL_VERSION; - argv[2] = NULL; - Tcl_DStringSetLength(&ds, 0); - Tcl_SetVar(interp, "tclDefaultLibrary", - Tcl_JoinPath(2, argv, &ds), TCL_GLOBAL_ONLY); - } - if ((RegQueryValueEx(key, "PkgPath", NULL, &type, NULL, &size) - == ERROR_SUCCESS) && (type == REG_MULTI_SZ)) { - char **argv; - int argc; + if (buf[0] != '\0') { + objPtr = Tcl_NewStringObj(buf, -1); + Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); + + TclWinNoBackslash(buf); + Tcl_SplitPath(buf, &pathc, &pathv); + + /* + * The lstrcmpi() will work even if pathv[pathc-1] is random UTF-8 + * chars because I know shortlib is ascii. + */ + + if ((pathc > 0) && (lstrcmpiA(shortlib, pathv[pathc - 1]) != 0)) { /* - * PkgPath is stored as an array of null terminated strings - * terminated by two null characters. First count the number - * of strings, then allocate an argv array so we can construct - * a valid list. + * TCL_LIBRARY is set but refers to a different tcl installation + * than the current version. Try fiddling with the specified + * directory to make it refer to this installation by removing the + * old "tclX.Y" and substituting the current version string. */ - Tcl_DStringSetLength(&ds, size); - RegQueryValueEx(key, "PkgPath", NULL, NULL, - (LPBYTE)Tcl_DStringValue(&ds), &size); - argc = 0; - p = Tcl_DStringValue(&ds); - do { - if (*p) { - argc++; - } - p += strlen(p) + 1; - } while (*p); - - argv = (char **) ckalloc((sizeof(char *) * argc) + 1); - argc = 0; - p = Tcl_DStringValue(&ds); - do { - if (*p) { - argv[argc++] = p; - while (*p) { - if (*p == '\\') { - *p = '/'; - } - p++; - } - } - p++; - } while (*p); - - p = Tcl_Merge(argc, argv); - Tcl_SetVar(interp, "tcl_pkgPath", p, TCL_GLOBAL_ONLY); - ckfree(p); - ckfree((char*) argv); + pathv[pathc - 1] = shortlib; + Tcl_DStringInit(&ds); + (void) Tcl_JoinPath(pathc, pathv, &ds); + objPtr = TclDStringToObj(&ds); } else { - char *argv[3]; - argv[0] = Tcl_GetVar(interp, "tclDefaultLibrary", TCL_GLOBAL_ONLY); - argv[1] = ".."; - argv[2] = NULL; - Tcl_DStringSetLength(&ds, 0); - Tcl_SetVar(interp, "tcl_pkgPath", Tcl_JoinPath(2, argv, &ds), - TCL_GLOBAL_ONLY|TCL_LIST_ELEMENT); + objPtr = Tcl_NewStringObj(buf, -1); + } + Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); + ckfree(pathv); + } +} + +/* + *--------------------------------------------------------------------------- + * + * InitializeDefaultLibraryDir -- + * + * Locate the Tcl script library default location relative to the + * location of the Tcl DLL. + * + * Results: + * None. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +static void +InitializeDefaultLibraryDir( + char **valuePtr, + int *lengthPtr, + Tcl_Encoding *encodingPtr) +{ + HMODULE hModule = TclWinGetTclInstance(); + WCHAR wName[MAX_PATH + LIBRARY_SIZE]; + char name[(MAX_PATH + LIBRARY_SIZE) * TCL_UTF_MAX]; + char *end, *p; + + if (GetModuleFileNameW(hModule, wName, MAX_PATH) == 0) { + GetModuleFileNameA(hModule, name, MAX_PATH); + } else { + ToUtf(wName, name); + } + + end = strrchr(name, '\\'); + *end = '\0'; + p = strrchr(name, '\\'); + if (p != NULL) { + end = p; + } + *end = '\\'; + + TclWinNoBackslash(name); + sprintf(end + 1, "lib/tcl%s", TCL_VERSION); + *lengthPtr = strlen(name); + *valuePtr = ckalloc(*lengthPtr + 1); + *encodingPtr = NULL; + memcpy(*valuePtr, name, (size_t) *lengthPtr + 1); +} + +/* + *--------------------------------------------------------------------------- + * + * InitializeSourceLibraryDir -- + * + * Locate the Tcl script library default location relative to the + * location of the Tcl DLL as it exists in the build output directory + * associated with the source checkout. + * + * Results: + * None. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +static void +InitializeSourceLibraryDir( + char **valuePtr, + int *lengthPtr, + Tcl_Encoding *encodingPtr) +{ + HMODULE hModule = TclWinGetTclInstance(); + WCHAR wName[MAX_PATH + LIBRARY_SIZE]; + char name[(MAX_PATH + LIBRARY_SIZE) * TCL_UTF_MAX]; + char *end, *p; + + if (GetModuleFileNameW(hModule, wName, MAX_PATH) == 0) { + GetModuleFileNameA(hModule, name, MAX_PATH); + } else { + ToUtf(wName, name); + } + + end = strrchr(name, '\\'); + *end = '\0'; + p = strrchr(name, '\\'); + if (p != NULL) { + end = p; + } + *end = '\\'; + + TclWinNoBackslash(name); + sprintf(end + 1, "../library"); + *lengthPtr = strlen(name); + *valuePtr = ckalloc(*lengthPtr + 1); + *encodingPtr = NULL; + memcpy(*valuePtr, name, (size_t) *lengthPtr + 1); +} + +/* + *--------------------------------------------------------------------------- + * + * ToUtf -- + * + * Convert a char string to a UTF string. + * + * Results: + * None. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +static int +ToUtf( + const WCHAR *wSrc, + char *dst) +{ + char *start; + + start = dst; + while (*wSrc != '\0') { + dst += Tcl_UniCharToUtf(*wSrc, dst); + wSrc++; + } + *dst = '\0'; + return (int) (dst - start); +} + +/* + *--------------------------------------------------------------------------- + * + * TclpSetInitialEncodings -- + * + * Based on the locale, determine the encoding of the operating system + * and the default encoding for newly opened files. + * + * Called at process initialization time, and part way through startup, + * we verify that the initial encodings were correctly setup. Depending + * on Tcl's environment, there may not have been enough information first + * time through (above). + * + * Results: + * None. + * + * Side effects: + * The Tcl library path is converted from native encoding to UTF-8, on + * the first call, and the encodings may be changed on first or second + * call. + * + *--------------------------------------------------------------------------- + */ + +void +TclpSetInitialEncodings(void) +{ + Tcl_DString encodingName; + + TclpSetInterfaces(); + Tcl_SetSystemEncoding(NULL, + Tcl_GetEncodingNameFromEnvironment(&encodingName)); + Tcl_DStringFree(&encodingName); +} + +void TclWinSetInterfaces( + int dummy) /* Not used. */ +{ + TclpSetInterfaces(); +} + +const char * +Tcl_GetEncodingNameFromEnvironment( + Tcl_DString *bufPtr) +{ + Tcl_DStringInit(bufPtr); + Tcl_DStringSetLength(bufPtr, 2+TCL_INTEGER_SPACE); + wsprintfA(Tcl_DStringValue(bufPtr), "cp%d", GetACP()); + Tcl_DStringSetLength(bufPtr, strlen(Tcl_DStringValue(bufPtr))); + return Tcl_DStringValue(bufPtr); +} + +/* + *--------------------------------------------------------------------------- + * + * TclpSetVariables -- + * + * Performs platform-specific interpreter initialization related to the + * tcl_platform and env variables, and other platform-specific things. + * + * Results: + * None. + * + * Side effects: + * Sets "tcl_platform", and "env(HOME)" Tcl variables. + * + *---------------------------------------------------------------------- + */ + +void +TclpSetVariables( + Tcl_Interp *interp) /* Interp to initialize. */ +{ + const char *ptr; + char buffer[TCL_INTEGER_SPACE * 2]; + union { + SYSTEM_INFO info; + OemId oemId; + } sys; + static OSVERSIONINFOW osInfo; + static int osInfoInitialized = 0; + Tcl_DString ds; + TCHAR szUserName[UNLEN+1]; + DWORD cchUserNameLen = UNLEN; + + Tcl_SetVar2Ex(interp, "tclDefaultLibrary", NULL, + TclGetProcessGlobalValue(&defaultLibraryDir), TCL_GLOBAL_ONLY); + + if (!osInfoInitialized) { + HANDLE handle = LoadLibraryW(L"NTDLL"); + int(__stdcall *getversion)(void *) = + (int(__stdcall *)(void *)) GetProcAddress(handle, "RtlGetVersion"); + osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW); + if (!getversion || getversion(&osInfo)) { + GetVersionExW(&osInfo); } + if (handle) { + FreeLibrary(handle); + } + osInfoInitialized = 1; } + GetSystemInfo(&sys.info); /* * Define the tcl_platform array. @@ -232,24 +560,25 @@ TclPlatformInit(interp) Tcl_SetVar2(interp, "tcl_platform", "os", platforms[osInfo.dwPlatformId], TCL_GLOBAL_ONLY); } - sprintf(buffer, "%d.%d", osInfo.dwMajorVersion, osInfo.dwMinorVersion); + wsprintfA(buffer, "%d.%d", osInfo.dwMajorVersion, osInfo.dwMinorVersion); Tcl_SetVar2(interp, "tcl_platform", "osVersion", buffer, TCL_GLOBAL_ONLY); - if (oemId->wProcessorArchitecture < NUMPROCESSORS) { + if (sys.oemId.wProcessorArchitecture < NUMPROCESSORS) { Tcl_SetVar2(interp, "tcl_platform", "machine", - processors[oemId->wProcessorArchitecture], + processors[sys.oemId.wProcessorArchitecture], TCL_GLOBAL_ONLY); } #ifdef _DEBUG /* - * The existence of the "debug" element of the tcl_platform array indicates - * that this particular Tcl shell has been compiled with debug information. - * Using "info exists tcl_platform(debug)" a Tcl script can direct the - * interpreter to load debug versions of DLLs with the load command. + * The existence of the "debug" element of the tcl_platform array + * indicates that this particular Tcl shell has been compiled with debug + * information. Using "info exists tcl_platform(debug)" a Tcl script can + * direct the interpreter to load debug versions of DLLs with the load + * command. */ Tcl_SetVar2(interp, "tcl_platform", "debug", "1", - TCL_GLOBAL_ONLY); + TCL_GLOBAL_ONLY); #endif /* @@ -257,16 +586,16 @@ TclPlatformInit(interp) * environment variables, if necessary. */ - p = Tcl_GetVar2(interp, "env", "HOME", TCL_GLOBAL_ONLY); - if (p == NULL) { - Tcl_DStringSetLength(&ds, 0); - p = Tcl_GetVar2(interp, "env", "HOMEDRIVE", TCL_GLOBAL_ONLY); - if (p != NULL) { - Tcl_DStringAppend(&ds, p, -1); + Tcl_DStringInit(&ds); + ptr = Tcl_GetVar2(interp, "env", "HOME", TCL_GLOBAL_ONLY); + if (ptr == NULL) { + ptr = Tcl_GetVar2(interp, "env", "HOMEDRIVE", TCL_GLOBAL_ONLY); + if (ptr != NULL) { + Tcl_DStringAppend(&ds, ptr, -1); } - p = Tcl_GetVar2(interp, "env", "HOMEPATH", TCL_GLOBAL_ONLY); - if (p != NULL) { - Tcl_DStringAppend(&ds, p, -1); + ptr = Tcl_GetVar2(interp, "env", "HOMEPATH", TCL_GLOBAL_ONLY); + if (ptr != NULL) { + Tcl_DStringAppend(&ds, ptr, -1); } if (Tcl_DStringLength(&ds) > 0) { Tcl_SetVar2(interp, "env", "HOME", Tcl_DStringValue(&ds), @@ -276,121 +605,117 @@ TclPlatformInit(interp) } } - Tcl_DStringFree(&ds); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_Init -- - * - * This procedure is typically invoked by Tcl_AppInit procedures - * to perform additional initialization for a Tcl interpreter, - * such as sourcing the "init.tcl" script. - * - * Results: - * Returns a standard Tcl completion code and sets interp->result - * if there is an error. - * - * Side effects: - * Depends on what's in the init.tcl script. - * - *---------------------------------------------------------------------- - */ + /* + * Initialize the user name from the environment first, since this is much + * faster than asking the system. + * Note: cchUserNameLen is number of characters including nul terminator. + */ -int -Tcl_Init(interp) - Tcl_Interp *interp; /* Interpreter to initialize. */ -{ - if (tclPreInitScript != NULL) { - if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) { - return (TCL_ERROR); - }; + Tcl_DStringInit(&ds); + if (TclGetEnv("USERNAME", &ds) == NULL) { + if (GetUserName(szUserName, &cchUserNameLen) != 0) { + int cbUserNameLen = cchUserNameLen - 1; + cbUserNameLen *= sizeof(TCHAR); + Tcl_WinTCharToUtf(szUserName, cbUserNameLen, &ds); + } } - return(Tcl_Eval(interp, initScript)); -} - -/* - *---------------------------------------------------------------------- - * - * TclWinGetPlatform -- - * - * This is a kludge that allows the test library to get access - * the internal tclPlatform variable. - * - * Results: - * Returns a pointer to the tclPlatform variable. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ + Tcl_SetVar2(interp, "tcl_platform", "user", Tcl_DStringValue(&ds), + TCL_GLOBAL_ONLY); + Tcl_DStringFree(&ds); -TclPlatformType * -TclWinGetPlatform() -{ - return &tclPlatform; + /* + * Define what the platform PATH separator is. [TIP #315] + */ + + Tcl_SetVar2(interp, "tcl_platform","pathSeparator", ";", TCL_GLOBAL_ONLY); } /* *---------------------------------------------------------------------- * - * Tcl_SourceRCFile -- + * TclpFindVariable -- * - * This procedure is typically invoked by Tcl_Main of Tk_Main - * procedure to source an application specific rc file into the - * interpreter at startup time. + * Locate the entry in environ for a given name. On Unix this routine is + * case sensitive, on Windows this matches mioxed case. * * Results: - * None. + * 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: - * Depends on what's in the rc script. + * None. * *---------------------------------------------------------------------- */ -void -Tcl_SourceRCFile(interp) - Tcl_Interp *interp; /* Interpreter to source rc file into. */ +int +TclpFindVariable( + 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). */ { - Tcl_DString temp; - char *fileName; - Tcl_Channel errChannel; + int i, length, result = -1; + register const char *env, *p1, *p2; + char *envUpper, *nameUpper; + Tcl_DString envString; - fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY); + /* + * Convert the name to all upper case for the case insensitive comparison. + */ - if (fileName != NULL) { - Tcl_Channel c; - char *fullName; + length = strlen(name); + nameUpper = ckalloc(length + 1); + memcpy(nameUpper, 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 = (int) (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_DStringInit(&temp); - fullName = Tcl_TranslateFileName(interp, fileName, &temp); - if (fullName == NULL) { - /* - * Couldn't translate the file name (e.g. it referred to a - * bogus user or there was no HOME environment variable). - * Just do nothing. - */ - } else { + Tcl_DStringFree(&envString); + } - /* - * Test for the existence of the rc file before trying to read it. - */ + *lengthPtr = i; - c = Tcl_OpenFileChannel(NULL, fullName, "r", 0); - if (c != (Tcl_Channel) NULL) { - Tcl_Close(NULL, c); - if (Tcl_EvalFile(interp, fullName) != TCL_OK) { - errChannel = Tcl_GetStdChannel(TCL_STDERR); - if (errChannel) { - Tcl_Write(errChannel, interp->result, -1); - Tcl_Write(errChannel, "\n", 1); - } - } - } - } - Tcl_DStringFree(&temp); - } + done: + Tcl_DStringFree(&envString); + ckfree(nameUpper); + return result; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ |