/* * 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. * * RCS: @(#) $Id: tclWinInit.c,v 1.66 2005/05/10 18:35:39 kennykb Exp $ */ #include "tclWinInt.h" #include #include #include /* * 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 /* * The following arrays contain the human readable strings for the Windows * platform and processor values. */ #define NUMPLATFORMS 4 static char* platforms[NUMPLATFORMS] = { "Win32s", "Windows 95", "Windows NT", "Windows CE" }; #define NUMPROCESSORS 11 static char* 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 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. * * Called at process initialization time. * * Results: * None. * * Side effects: * None. * *--------------------------------------------------------------------------- */ void TclpInitPlatform() { tclPlatform = TCL_PLATFORM_WINDOWS; /* * 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); #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(valuePtr, lengthPtr, encodingPtr) char **valuePtr; int *lengthPtr; Tcl_Encoding *encodingPtr; { #define LIBRARY_SIZE 32 Tcl_Obj *pathPtr; char installLib[LIBRARY_SIZE]; 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)); *encodingPtr = NULL; bytes = Tcl_GetStringFromObj(pathPtr, lengthPtr); *valuePtr = ckalloc((unsigned int)(*lengthPtr)+1); memcpy((VOID *) *valuePtr, (VOID *) 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)) { CONST char *str; /* * 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); str = Tcl_JoinPath(pathc, pathv, &ds); objPtr = Tcl_NewStringObj(str, Tcl_DStringLength(&ds)); Tcl_DStringFree(&ds); } else { objPtr = Tcl_NewStringObj(buf, -1); } Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); ckfree((char *) 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(valuePtr, lengthPtr, encodingPtr) 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((unsigned int) *lengthPtr + 1); *encodingPtr = NULL; memcpy((VOID *) *valuePtr, (VOID *) 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); } /* *--------------------------------------------------------------------------- * * TclWinEncodingsCleanup -- * * Reset information to its original state in finalization to * allow for reinitialization to be possible. This must not * be called until after the filesystem has been finalised, or * exit crashes may occur when using virtual filesystems. * * Results: * None. * * Side effects: * Static information reset to startup state. * *--------------------------------------------------------------------------- */ void TclWinEncodingsCleanup() { TclWinResetInterfaceEncodings(); } /* *--------------------------------------------------------------------------- * * 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() { Tcl_DString encodingName; TclpSetInterfaces(); Tcl_SetSystemEncoding(NULL, TclpGetEncodingNameFromEnvironment(&encodingName)); Tcl_DStringFree(&encodingName); } void TclpSetInterfaces() { int platformId, useWide; platformId = TclWinGetPlatformId(); useWide = ((platformId == VER_PLATFORM_WIN32_NT) || (platformId == VER_PLATFORM_WIN32_CE)); TclWinSetInterfaces(useWide); } CONST char * TclpGetEncodingNameFromEnvironment(bufPtr) Tcl_DString *bufPtr; { Tcl_DStringInit(bufPtr); wsprintfA(Tcl_DStringValue(bufPtr), "cp%d", GetACP()); 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(interp) Tcl_Interp *interp; /* Interp to initialize. */ { CONST char *ptr; char buffer[TCL_INTEGER_SPACE * 2]; SYSTEM_INFO sysInfo; OemId *oemId; OSVERSIONINFOA osInfo; Tcl_DString ds; TCHAR szUserName[UNLEN+1]; DWORD dwUserNameLen = sizeof(szUserName); Tcl_SetVar2Ex(interp, "tclDefaultLibrary", NULL, TclGetProcessGlobalValue(&defaultLibraryDir), TCL_GLOBAL_ONLY); osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA); GetVersionExA(&osInfo); oemId = (OemId *) &sysInfo; GetSystemInfo(&sysInfo); /* * 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 (oemId->wProcessorArchitecture < NUMPROCESSORS) { Tcl_SetVar2(interp, "tcl_platform", "machine", processors[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. */ Tcl_DStringInit(&ds); if (TclGetEnv("USERNAME", &ds) == NULL) { if (GetUserName(szUserName, &dwUserNameLen) != 0) { Tcl_WinTCharToUtf(szUserName, (int) dwUserNameLen, &ds); } } Tcl_SetVar2(interp, "tcl_platform", "user", Tcl_DStringValue(&ds), TCL_GLOBAL_ONLY); Tcl_DStringFree(&ds); } /* *---------------------------------------------------------------------- * * TclpFindVariable -- * * Locate the entry in environ for a given name. On Unix this * routine is case sensetive, on Windows this matches mioxed case. * * Results: * The return value is the index in environ of an entry with the * name "name", or -1 if there is no such entry. The integer at * *lengthPtr is filled in with the length of name (if a matching * entry is found) or the length of the environ array (if no matching * entry is found). * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclpFindVariable(name, lengthPtr) CONST char *name; /* Name of desired environment variable * (UTF-8). */ int *lengthPtr; /* Used to return length of name (for * successful searches) or number of non-NULL * entries in environ (for unsuccessful * searches). */ { int i, length, result = -1; register CONST char *env, *p1, *p2; char *envUpper, *nameUpper; Tcl_DString envString; /* * Convert the name to all upper case for the case insensitive * comparison. */ length = strlen(name); nameUpper = (char *) ckalloc((unsigned) length+1); memcpy((VOID *) nameUpper, (VOID *) name, (size_t) length+1); Tcl_UtfToUpper(nameUpper); Tcl_DStringInit(&envString); for (i = 0, env = environ[i]; env != NULL; i++, env = environ[i]) { /* * Chop the env string off after the equal sign, then Convert * the name to all upper case, so we do not have to convert * all the characters after the equal sign. */ envUpper = Tcl_ExternalToUtfDString(NULL, env, -1, &envString); p1 = strchr(envUpper, '='); if (p1 == NULL) { continue; } length = (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; }