diff options
author | William Joye <wjoye@cfa.harvard.edu> | 2017-10-17 19:50:58 (GMT) |
---|---|---|
committer | William Joye <wjoye@cfa.harvard.edu> | 2017-10-17 19:50:58 (GMT) |
commit | 9b7a6c3507ea3383c60aaecb29f873c9b590ccca (patch) | |
tree | 82ce31ebd8f46803d969034f5aa3db8d7974493c /tcl8.6/win/tclWinInit.c | |
parent | 87fca7325b97005eb44dcf3e198277640af66115 (diff) | |
download | blt-9b7a6c3507ea3383c60aaecb29f873c9b590ccca.zip blt-9b7a6c3507ea3383c60aaecb29f873c9b590ccca.tar.gz blt-9b7a6c3507ea3383c60aaecb29f873c9b590ccca.tar.bz2 |
rm tcl/tk 8.6.7
Diffstat (limited to 'tcl8.6/win/tclWinInit.c')
-rw-r--r-- | tcl8.6/win/tclWinInit.c | 733 |
1 files changed, 0 insertions, 733 deletions
diff --git a/tcl8.6/win/tclWinInit.c b/tcl8.6/win/tclWinInit.c deleted file mode 100644 index 98c7ed5..0000000 --- a/tcl8.6/win/tclWinInit.c +++ /dev/null @@ -1,733 +0,0 @@ -/* - * tclWinInit.c -- - * - * Contains the Windows-specific interpreter initialization functions. - * - * Copyright (c) 1994-1997 Sun Microsystems, Inc. - * Copyright (c) 1998-1999 by Scriptics Corporation. - * All rights reserved. - * - * 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 <winnt.h> -#include <winbase.h> -#include <lmcons.h> - -/* - * GetUserName() is found in advapi32.dll - */ -#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. - */ - -typedef struct { - WORD wProcessorArchitecture; - WORD wReserved; -} OemId; - -/* - * The following macros are missing from some versions of winnt.h. - */ - -#ifndef PROCESSOR_ARCHITECTURE_INTEL -#define PROCESSOR_ARCHITECTURE_INTEL 0 -#endif -#ifndef PROCESSOR_ARCHITECTURE_MIPS -#define PROCESSOR_ARCHITECTURE_MIPS 1 -#endif -#ifndef PROCESSOR_ARCHITECTURE_ALPHA -#define PROCESSOR_ARCHITECTURE_ALPHA 2 -#endif -#ifndef PROCESSOR_ARCHITECTURE_PPC -#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 -#endif - - -/* - * Windows version dependend functions - */ -TclWinProcs tclWinProcs; - -/* - * The following arrays contain the human readable strings for the Windows - * platform and processor values. - */ - - -#define NUMPLATFORMS 4 -static const char *const platforms[NUMPLATFORMS] = { - "Win32s", "Windows 95", "Windows NT", "Windows CE" -}; - -#define NUMPROCESSORS 11 -static const char *const processors[NUMPROCESSORS] = { - "intel", "mips", "alpha", "ppc", "shx", "arm", "ia64", "alpha64", "msil", - "amd64", "ia32_on_win64" -}; - -/* - * The default directory in which the init.tcl file is expected to be found. - */ - -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 -- - * - * Initialize all the platform-dependant things like signals, - * floating-point error handling and sockets. - * - * Called at process initialization time. - * - * Results: - * None. - * - * Side effects: - * None. - * - *--------------------------------------------------------------------------- - */ - -void -TclpInitPlatform(void) -{ - WSADATA wsaData; - WORD wVersionRequested = MAKEWORD(2, 2); - HMODULE handle; - - tclPlatform = TCL_PLATFORM_WINDOWS; - - /* - * 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 - - /* - * Fill available functions depending on windows version - */ - handle = GetModuleHandle(TEXT("KERNEL32")); - tclWinProcs.cancelSynchronousIo = - (BOOL (WINAPI *)(HANDLE)) GetProcAddress(handle, - "CancelSynchronousIo"); -} - -/* - *------------------------------------------------------------------------- - * - * 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(); - - /* - * 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); - - /* - * 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 in its default location. - */ - - 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"); - } - - /* - * 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'; - GetEnvironmentVariableA("TCL_LIBRARY", buf, MAX_PATH); - } else { - ToUtf(wBuf, buf); - } - - 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)) { - /* - * 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] = shortlib; - Tcl_DStringInit(&ds); - (void) Tcl_JoinPath(pathc, pathv, &ds); - objPtr = TclDStringToObj(&ds); - } else { - 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) { - HMODULE handle = GetModuleHandle(TEXT("NTDLL")); - int(__stdcall *getversion)(void *) = - (int(__stdcall *)(void *)) GetProcAddress(handle, "RtlGetVersion"); - osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW); - if (!getversion || getversion(&osInfo)) { - GetVersionExW(&osInfo); - } - osInfoInitialized = 1; - } - GetSystemInfo(&sys.info); - - /* - * Define the tcl_platform array. - */ - - Tcl_SetVar2(interp, "tcl_platform", "platform", "windows", - TCL_GLOBAL_ONLY); - if (osInfo.dwPlatformId < NUMPLATFORMS) { - Tcl_SetVar2(interp, "tcl_platform", "os", - platforms[osInfo.dwPlatformId], TCL_GLOBAL_ONLY); - } - wsprintfA(buffer, "%d.%d", osInfo.dwMajorVersion, osInfo.dwMinorVersion); - Tcl_SetVar2(interp, "tcl_platform", "osVersion", buffer, TCL_GLOBAL_ONLY); - if (sys.oemId.wProcessorArchitecture < NUMPROCESSORS) { - Tcl_SetVar2(interp, "tcl_platform", "machine", - 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. - */ - - Tcl_SetVar2(interp, "tcl_platform", "debug", "1", - TCL_GLOBAL_ONLY); -#endif - - /* - * Set up the HOME environment variable from the HOMEDRIVE & HOMEPATH - * environment variables, if necessary. - */ - - 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); - } - 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), - TCL_GLOBAL_ONLY); - } else { - Tcl_SetVar2(interp, "env", "HOME", "c:\\", TCL_GLOBAL_ONLY); - } - } - - /* - * 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_DStringInit(&ds); - if (TclGetEnv("USERNAME", &ds) == NULL) { - 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); -} - -/* - *---------------------------------------------------------------------- - * - * TclpFindVariable -- - * - * 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). - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -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). */ -{ - 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 = 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_DStringFree(&envString); - } - - *lengthPtr = i; - - done: - Tcl_DStringFree(&envString); - ckfree(nameUpper); - return result; -} - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ |