diff options
Diffstat (limited to 'win/tclWinInit.c')
| -rw-r--r-- | win/tclWinInit.c | 767 |
1 files changed, 322 insertions, 445 deletions
diff --git a/win/tclWinInit.c b/win/tclWinInit.c index 7576763..8b600f6 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -1,4 +1,4 @@ -/* +/* * tclWinInit.c -- * * Contains the Windows-specific interpreter initialization functions. @@ -7,28 +7,27 @@ * Copyright (c) 1998-1999 by Scriptics Corporation. * All rights reserved. * - * RCS: @(#) $Id: tclWinInit.c,v 1.23 2000/06/13 20:30:23 ericm Exp $ + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclWinInt.h" -#include <winreg.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 { @@ -41,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 /* @@ -62,41 +82,39 @@ 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" }; /* - * Thread id used for asynchronous notification from signal handlers. + * The default directory in which the init.tcl file is expected to be found. */ -static DWORD mainThreadId; - -/* - * The Init script (common to Windows and Unix platforms) is - * defined in tkInitScript.h - */ +static TclInitProcessGlobalValueProc InitializeDefaultLibraryDir; +static ProcessGlobalValue defaultLibraryDir = + {0, 0, NULL, NULL, InitializeDefaultLibraryDir, NULL, NULL}; -#include "tclInitScript.h" +static TclInitProcessGlobalValueProc InitializeSourceLibraryDir; +static ProcessGlobalValue sourceLibraryDir = + {0, 0, NULL, NULL, InitializeSourceLibraryDir, NULL, NULL}; -static void AppendEnvironment(Tcl_Obj *listPtr, CONST char *lib); -static void AppendDllPath(Tcl_Obj *listPtr, HMODULE hModule, - CONST char *lib); -static int ToUtf(CONST WCHAR *wSrc, char *dst); +static void AppendEnvironment(Tcl_Obj *listPtr, const char *lib); +static int ToUtf(const WCHAR *wSrc, char *dst); /* *--------------------------------------------------------------------------- * * TclpInitPlatform -- * - * Initialize all the platform-dependant things like signals and - * floating-point error handling. + * Initialize all the platform-dependant things like signals, + * floating-point error handling and sockets. * * Called at process initialization time. * @@ -110,39 +128,24 @@ static int ToUtf(CONST WCHAR *wSrc, char *dst); */ void -TclpInitPlatform() +TclpInitPlatform(void) { - tclPlatform = TCL_PLATFORM_WINDOWS; + WSADATA wsaData; + WORD wVersionRequested = MAKEWORD(2, 2); - /* - * The following code stops Windows 3.X and Windows NT 3.51 from - * automatically putting up Sharing Violation dialogs, e.g, when - * someone tries to access a file that is locked or a drive with no - * disk in it. Tcl already returns the appropriate error to the - * caller, and they can decide to put up their own dialog in response - * to that failure. - * - * Under 95 and NT 4.0, this is a NOOP because the system doesn't - * automatically put up dialogs when the above operations fail. - */ - - SetErrorMode(SetErrorMode(0) | SEM_FAILCRITICALERRORS); + tclPlatform = TCL_PLATFORM_WINDOWS; /* - * Save the id of the first thread to intialize the Tcl library. This - * thread will be used to handle notifications from async event - * procedures. This is not strictly correct. A better solution involves - * using a designated "main" notifier that is kept up to date as threads - * come and go. + * Initialize the winsock library. On Windows XP and higher this + * can never fail. */ - - mainThreadId = GetCurrentThreadId(); + 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. + * 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)); @@ -150,149 +153,71 @@ TclpInitPlatform() } /* - *--------------------------------------------------------------------------- + *------------------------------------------------------------------------- * * TclpInitLibraryPath -- * - * Initialize the library path at startup. - * - * This call sets the library path to strings in UTF-8. Any - * pre-existing library path information is assumed to have been - * in the native multibyte encoding. - * - * Called at process initialization time. + * 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: - * None. + * Sets the library path to an initial value. * - *--------------------------------------------------------------------------- + *------------------------------------------------------------------------- */ void -TclpInitLibraryPath(path) - CONST char *path; /* Potentially dirty UTF string that is */ - /* the path to the executable name. */ +TclpInitLibraryPath( + char **valuePtr, + int *lengthPtr, + Tcl_Encoding *encodingPtr) { -#define LIBRARY_SIZE 32 - Tcl_Obj *pathPtr, *objPtr; - char *str; - Tcl_DString ds; - int pathc; - char **pathv; - char installLib[LIBRARY_SIZE], developLib[LIBRARY_SIZE]; +#define LIBRARY_SIZE 64 + Tcl_Obj *pathPtr; + char installLib[LIBRARY_SIZE]; + const char *bytes; - Tcl_DStringInit(&ds); pathPtr = Tcl_NewObj(); /* - * Initialize the substrings used when locating an executable. The - * installLib variable computes the path as though the executable - * is installed. The developLib computes the path as though the - * executable is run from a develpment directory. + * Initialize the substring used when locating the script library. The + * installLib variable computes the script library path relative to the + * installed DLL. */ sprintf(installLib, "lib/tcl%s", TCL_VERSION); - sprintf(developLib, "../tcl%s/library", - ((TCL_RELEASE_LEVEL < 2) ? TCL_PATCH_LEVEL : TCL_VERSION)); - - /* - * Look for the library relative to default encoding dir. - */ - - str = Tcl_GetDefaultEncodingDir(); - if ((str != NULL) && (str[0] != '\0')) { - objPtr = Tcl_NewStringObj(str, -1); - Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); - } /* - * 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. + * 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. */ AppendEnvironment(pathPtr, installLib); /* - * Look for the library relative to the DLL. Only use the installLib - * because in practice, the DLL is always installed. + * Look for the library in its default location. */ - AppendDllPath(pathPtr, TclWinGetTclInstance(), installLib); - + Tcl_ListObjAppendElement(NULL, pathPtr, + TclGetProcessGlobalValue(&defaultLibraryDir)); /* - * Look for the library relative to the executable. This algorithm - * should be the same as the one in the tcl_findLibrary procedure. - * - * This code looks in the following directories: - * - * <bindir>/../<installLib> - * (e.g. /usr/local/bin/../lib/tcl8.2) - * <bindir>/../../<installLib> - * (e.g. /usr/local/TclPro/solaris-sparc/bin/../../lib/tcl8.2) - * <bindir>/../library - * (e.g. /usr/src/tcl8.2/unix/../library) - * <bindir>/../../library - * (e.g. /usr/src/tcl8.2/unix/solaris-sparc/../../library) - * <bindir>/../../<developLib> - * (e.g. /usr/src/tcl8.2/unix/../../tcl8.2/library) - * <bindir>/../../../<devlopLib> - * (e.g. /usr/src/tcl8.2/unix/solaris-sparc/../../../tcl8.2/library) + * Look for the library in its source checkout location. */ - - if (path != NULL) { - Tcl_SplitPath(path, &pathc, &pathv); - if (pathc > 1) { - pathv[pathc - 2] = installLib; - path = Tcl_JoinPath(pathc - 1, pathv, &ds); - objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds)); - Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); - Tcl_DStringFree(&ds); - } - if (pathc > 2) { - pathv[pathc - 3] = installLib; - path = Tcl_JoinPath(pathc - 2, pathv, &ds); - objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds)); - Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); - Tcl_DStringFree(&ds); - } - if (pathc > 1) { - pathv[pathc - 2] = "library"; - path = Tcl_JoinPath(pathc - 1, pathv, &ds); - objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds)); - Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); - Tcl_DStringFree(&ds); - } - if (pathc > 2) { - pathv[pathc - 3] = "library"; - path = Tcl_JoinPath(pathc - 2, pathv, &ds); - objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds)); - Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); - Tcl_DStringFree(&ds); - } - if (pathc > 1) { - pathv[pathc - 3] = developLib; - path = Tcl_JoinPath(pathc - 2, pathv, &ds); - objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds)); - Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); - Tcl_DStringFree(&ds); - } - if (pathc > 3) { - pathv[pathc - 4] = developLib; - path = Tcl_JoinPath(pathc - 3, pathv, &ds); - objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds)); - Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); - Tcl_DStringFree(&ds); - } - ckfree((char *) pathv); - } - TclSetLibraryPath(pathPtr); + 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); } /* @@ -300,9 +225,9 @@ TclpInitLibraryPath(path) * * 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., + * 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: @@ -317,23 +242,41 @@ TclpInitLibraryPath(path) static void AppendEnvironment( Tcl_Obj *pathPtr, - CONST char *lib) + const char *lib) { int pathc; WCHAR wBuf[MAX_PATH]; char buf[MAX_PATH * TCL_UTF_MAX]; Tcl_Obj *objPtr; - char *str; Tcl_DString ds; - char **pathv; + const char **pathv; + char *shortlib; /* - * The "L" preceeding the TCL_LIBRARY string is used to tell VC++ - * that this is a unicode string. + * 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"); + } + + /* + * The "L" preceeding the TCL_LIBRARY string is used to tell VC++ that + * this is a unicode string. + */ + if (GetEnvironmentVariableW(L"TCL_LIBRARY", wBuf, MAX_PATH) == 0) { - buf[0] = '\0'; + buf[0] = '\0'; GetEnvironmentVariableA("TCL_LIBRARY", buf, MAX_PATH); } else { ToUtf(wBuf, buf); @@ -346,40 +289,38 @@ AppendEnvironment( TclWinNoBackslash(buf); Tcl_SplitPath(buf, &pathc, &pathv); - /* - * The lstrcmpi() will work even if pathv[pathc - 1] is random - * UTF-8 chars because I know lib is ascii. + /* + * The lstrcmpi() will work even if pathv[pathc-1] is random UTF-8 + * chars because I know shortlib is ascii. */ - if ((pathc > 0) && (lstrcmpiA(lib + 4, pathv[pathc - 1]) != 0)) { + if ((pathc > 0) && (lstrcmpiA(shortlib, pathv[pathc - 1]) != 0)) { /* - * 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_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. */ - - pathv[pathc - 1] = (char *) (lib + 4); + + pathv[pathc - 1] = shortlib; Tcl_DStringInit(&ds); - str = Tcl_JoinPath(pathc, pathv, &ds); - objPtr = Tcl_NewStringObj(str, Tcl_DStringLength(&ds)); - Tcl_DStringFree(&ds); + (void) Tcl_JoinPath(pathc, pathv, &ds); + objPtr = TclDStringToObj(&ds); } else { objPtr = Tcl_NewStringObj(buf, -1); } Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); - ckfree((char *) pathv); + ckfree(pathv); } } /* *--------------------------------------------------------------------------- * - * AppendDllPath -- + * InitializeDefaultLibraryDir -- * - * Append a path onto the path pointer that tries to locate the Tcl - * library relative to the location of the Tcl DLL. + * Locate the Tcl script library default location relative to the + * location of the Tcl DLL. * * Results: * None. @@ -390,34 +331,88 @@ AppendEnvironment( *--------------------------------------------------------------------------- */ -static void -AppendDllPath( - Tcl_Obj *pathPtr, - HMODULE hModule, - CONST char *lib) +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); } - if (lib != NULL) { - char *end, *p; - - end = strrchr(name, '\\'); - *end = '\0'; - p = strrchr(name, '\\'); - if (p != NULL) { - end = p; - } - *end = '\\'; - strcpy(end + 1, lib); + + 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); - Tcl_ListObjAppendElement(NULL, pathPtr, Tcl_NewStringObj(name, -1)); + sprintf(end + 1, "../library"); + *lengthPtr = strlen(name); + *valuePtr = ckalloc(*lengthPtr + 1); + *encodingPtr = NULL; + memcpy(*valuePtr, name, (size_t) *lengthPtr + 1); } /* @@ -425,7 +420,7 @@ AppendDllPath( * * ToUtf -- * - * Convert a char string to a UTF string. + * Convert a char string to a UTF string. * * Results: * None. @@ -438,7 +433,7 @@ AppendDllPath( static int ToUtf( - CONST WCHAR *wSrc, + const WCHAR *wSrc, char *dst) { char *start; @@ -449,73 +444,59 @@ ToUtf( wSrc++; } *dst = '\0'; - return dst - start; + return (int) (dst - start); } - /* *--------------------------------------------------------------------------- * * TclpSetInitialEncodings -- * - * Based on the locale, determine the encoding of the operating - * system and the default encoding for newly opened files. + * Based on the locale, determine the encoding of the operating system + * and the default encoding for newly opened files. * - * Called at process initialization time. + * 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. + * 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() +TclpSetInitialEncodings(void) { - CONST char *encoding; - char buf[4 + TCL_INTEGER_SPACE]; - int platformId; - Tcl_Obj *pathPtr; + Tcl_DString encodingName; - platformId = TclWinGetPlatformId(); - - TclWinSetInterfaces(platformId == VER_PLATFORM_WIN32_NT); - - wsprintfA(buf, "cp%d", GetACP()); - Tcl_SetSystemEncoding(NULL, buf); - - if (platformId != VER_PLATFORM_WIN32_NT) { - pathPtr = TclGetLibraryPath(); - if (pathPtr != NULL) { - int i, objc; - Tcl_Obj **objv; - - objc = 0; - Tcl_ListObjGetElements(NULL, pathPtr, &objc, &objv); - for (i = 0; i < objc; i++) { - int length; - char *string; - Tcl_DString ds; - - string = Tcl_GetStringFromObj(objv[i], &length); - Tcl_ExternalToUtfDString(NULL, string, length, &ds); - Tcl_SetStringObj(objv[i], Tcl_DStringValue(&ds), - Tcl_DStringLength(&ds)); - Tcl_DStringFree(&ds); - } - } - } + TclpSetInterfaces(); + Tcl_SetSystemEncoding(NULL, + Tcl_GetEncodingNameFromEnvironment(&encodingName)); + Tcl_DStringFree(&encodingName); +} - /* - * Keep this encoding preloaded. The IO package uses it for gets on a - * binary channel. - */ +void TclWinSetInterfaces( + int dummy) /* Not used. */ +{ + TclpSetInterfaces(); +} - encoding = "iso8859-1"; - Tcl_GetEncoding(NULL, encoding); +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); } /* @@ -523,42 +504,51 @@ TclpSetInitialEncodings() * * TclpSetVariables -- * - * Performs platform-specific interpreter initialization related to - * the tcl_platform and env variables, and other platform-specific - * things. + * Performs platform-specific interpreter initialization related to the + * tcl_platform and env variables, and other platform-specific things. * * Results: * None. * * Side effects: - * Sets "tclDefaultLibrary", "tcl_platform", and "env(HOME)" Tcl - * variables. + * Sets "tcl_platform", and "env(HOME)" Tcl variables. * *---------------------------------------------------------------------- */ void -TclpSetVariables(interp) - Tcl_Interp *interp; /* Interp to initialize. */ -{ - char *ptr; +TclpSetVariables( + Tcl_Interp *interp) /* Interp to initialize. */ +{ + const char *ptr; char buffer[TCL_INTEGER_SPACE * 2]; - SYSTEM_INFO sysInfo; - OemId *oemId; - OSVERSIONINFOA osInfo; + union { + SYSTEM_INFO info; + OemId oemId; + } sys; + static OSVERSIONINFOW osInfo; + static int osInfoInitialized = 0; Tcl_DString ds; - - osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA); - GetVersionExA(&osInfo); - - oemId = (OemId *) &sysInfo; - GetSystemInfo(&sysInfo); - - /* - * Initialize the tclDefaultLibrary variable from the registry. - */ - - Tcl_SetVar(interp, "tclDefaultLibrary", "", TCL_GLOBAL_ONLY); + 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. @@ -572,18 +562,19 @@ TclpSetVariables(interp) } 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", @@ -617,17 +608,26 @@ TclpSetVariables(interp) /* * 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. */ - Tcl_DStringSetLength(&ds, 100); + Tcl_DStringInit(&ds); if (TclGetEnv("USERNAME", &ds) == NULL) { - if (GetUserName(Tcl_DStringValue(&ds), (LPDWORD) &Tcl_DStringLength(&ds)) == 0) { - Tcl_DStringSetLength(&ds, 0); + if (GetUserName(szUserName, &cchUserNameLen) != 0) { + int cbUserNameLen = cchUserNameLen - 1; + cbUserNameLen *= sizeof(TCHAR); + Tcl_WinTCharToUtf(szUserName, cbUserNameLen, &ds); } } Tcl_SetVar2(interp, "tcl_platform", "user", Tcl_DStringValue(&ds), TCL_GLOBAL_ONLY); Tcl_DStringFree(&ds); + + /* + * Define what the platform PATH separator is. [TIP #315] + */ + + Tcl_SetVar2(interp, "tcl_platform","pathSeparator", ";", TCL_GLOBAL_ONLY); } /* @@ -635,15 +635,14 @@ 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. + * Locate the entry in environ for a given name. On Unix this routine is + * case sensitive, 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). + * 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. @@ -652,43 +651,42 @@ TclpSetVariables(interp) */ int -TclpFindVariable(name, lengthPtr) - CONST char *name; /* Name of desired environment variable +TclpFindVariable( + const char *name, /* Name of desired environment variable * (UTF-8). */ - int *lengthPtr; /* Used to return length of name (for + 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; + register const char *env, *p1, *p2; char *envUpper, *nameUpper; Tcl_DString envString; /* - * Convert the name to all upper case for the case insensitive - * comparison. + * 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); + 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. + * 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; + length = (int) (p1 - envUpper); Tcl_DStringSetLength(&envString, length+1); Tcl_UtfToUpper(envUpper); @@ -702,143 +700,22 @@ TclpFindVariable(name, lengthPtr) result = i; goto done; } - + Tcl_DStringFree(&envString); } - + *lengthPtr = i; - done: + done: Tcl_DStringFree(&envString); ckfree(nameUpper); return result; } /* - *---------------------------------------------------------------------- - * - * 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 the interp's - * result if there is an error. - * - * Side effects: - * Depends on what's in the init.tcl script. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_Init(interp) - Tcl_Interp *interp; /* Interpreter to initialize. */ -{ - Tcl_Obj *pathPtr; - - if (tclPreInitScript != NULL) { - if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) { - return (TCL_ERROR); - }; - } - - pathPtr = TclGetLibraryPath(); - if (pathPtr == NULL) { - pathPtr = Tcl_NewObj(); - } - Tcl_SetVar2Ex(interp, "tcl_libPath", NULL, pathPtr, TCL_GLOBAL_ONLY); - return Tcl_Eval(interp, initScript); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SourceRCFile -- - * - * 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. - * - * Results: - * None. - * - * Side effects: - * Depends on what's in the rc script. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_SourceRCFile(interp) - Tcl_Interp *interp; /* Interpreter to source rc file into. */ -{ - Tcl_DString temp; - char *fileName; - Tcl_Channel errChannel; - - fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY); - - if (fileName != NULL) { - Tcl_Channel c; - char *fullName; - - 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 { - - /* - * Test for the existence of the rc file before trying to read it. - */ - - 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_WriteObj(errChannel, Tcl_GetObjResult(interp)); - Tcl_WriteChars(errChannel, "\n", 1); - } - } - } - } - Tcl_DStringFree(&temp); - } -} - -/* - *---------------------------------------------------------------------- - * - * TclpAsyncMark -- - * - * Wake up the main thread from a signal handler. - * - * Results: - * None. - * - * Side effects: - * Sends a message to the main thread. - * - *---------------------------------------------------------------------- + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: */ - -void -TclpAsyncMark(async) - Tcl_AsyncHandler async; /* Token for handler. */ -{ - /* - * Need a way to kick the Windows event loop and tell it to go look at - * asynchronous events. - */ - - PostThreadMessage(mainThreadId, WM_USER, 0, 0); -} |