/*
* tclWinInit.c --
*
* Contains the Windows-specific interpreter initialization functions.
*
* Copyright © 1994-1997 Sun Microsystems, Inc.
* Copyright © 1998-1999 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>
/*
* GetUserNameW() 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 arrays contain the human readable strings for the
* processor values.
*/
#define NUMPROCESSORS 15
static const char *const processors[NUMPROCESSORS] = {
"intel", "mips", "alpha", "ppc", "shx", "arm", "ia64", "alpha64", "msil",
"amd64", "ia32_on_win64", "neutral", "arm64", "arm32_on_win64", "ia32_on_arm64"
};
/*
* 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);
/*
*---------------------------------------------------------------------------
*
* TclpInitPlatform --
*
* Initialize all the platform-dependent 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);
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(GetModuleHandleW(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,
TCL_HASH_TYPE *lengthPtr,
Tcl_Encoding *encodingPtr)
{
#define LIBRARY_SIZE 64
Tcl_Obj *pathPtr;
char installLib[LIBRARY_SIZE];
const char *bytes;
Tcl_Size length;
TclNewObj(pathPtr);
/*
* Initialize the substring used when locating the script library. The
* installLib variable computes the script library path relative to the
* installed DLL.
*/
snprintf(installLib, sizeof(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 original 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, &length);
*lengthPtr = length++;
*valuePtr = (char *)Tcl_Alloc(length);
memcpy(*valuePtr, bytes, length);
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)
{
Tcl_Size pathc;
WCHAR wBuf[MAX_PATH];
char buf[MAX_PATH * 3];
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 ((size_t)(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" preceding the TCL_LIBRARY string is used to tell VC++ that
* this is a Unicode string.
*/
GetEnvironmentVariableW(L"TCL_LIBRARY", wBuf, MAX_PATH);
WideCharToMultiByte(CP_UTF8, 0, wBuf, -1, buf, MAX_PATH * 3, NULL, NULL);
if (buf[0] != '\0') {
objPtr = Tcl_NewStringObj(buf, TCL_INDEX_NONE);
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
TclWinNoBackslash(buf);
Tcl_SplitPath(buf, &pathc, &pathv);
/*
* The lstrcmpiA() 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 = Tcl_DStringToObj(&ds);
} else {
objPtr = Tcl_NewStringObj(buf, TCL_INDEX_NONE);
}
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
Tcl_Free((void *)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,
size_t *lengthPtr,
Tcl_Encoding *encodingPtr)
{
HMODULE hModule = (HMODULE)TclWinGetTclInstance();
WCHAR wName[MAX_PATH + LIBRARY_SIZE];
char name[(MAX_PATH + LIBRARY_SIZE) * 3];
char *end, *p;
GetModuleFileNameW(hModule, wName, sizeof(wName)/sizeof(WCHAR));
WideCharToMultiByte(CP_UTF8, 0, wName, -1, name, sizeof(name), NULL, NULL);
end = strrchr(name, '\\');
*end = '\0';
p = strrchr(name, '\\');
if (p != NULL) {
end = p;
}
*end = '\\';
TclWinNoBackslash(name);
snprintf(end + 1, LIBRARY_SIZE, "lib/tcl%s", TCL_VERSION);
*lengthPtr = strlen(name);
*valuePtr = (char *)Tcl_Alloc(*lengthPtr + 1);
*encodingPtr = NULL;
memcpy(*valuePtr, name, *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,
size_t *lengthPtr,
Tcl_Encoding *encodingPtr)
{
HMODULE hModule = (HMODULE)TclWinGetTclInstance();
WCHAR wName[MAX_PATH + LIBRARY_SIZE];
char name[(MAX_PATH + LIBRARY_SIZE) * 3];
char *end, *p;
GetModuleFileNameW(hModule, wName, sizeof(wName)/sizeof(WCHAR));
WideCharToMultiByte(CP_UTF8, 0, wName, -1, name, sizeof(name), NULL, NULL);
end = strrchr(name, '\\');
*end = '\0';
p = strrchr(name, '\\');
if (p != NULL) {
end = p;
}
*end = '\\';
TclWinNoBackslash(name);
snprintf(end + 1, LIBRARY_SIZE, "../library");
*lengthPtr = strlen(name);
*valuePtr = (char *)Tcl_Alloc(*lengthPtr + 1);
*encodingPtr = NULL;
memcpy(*valuePtr, name, *lengthPtr + 1);
}
/*
*---------------------------------------------------------------------------
*
* 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;
Tcl_SetSystemEncoding(NULL,
Tcl_GetEncodingNameFromEnvironment(&encodingName));
Tcl_DStringFree(&encodingName);
}
const char *
Tcl_GetEncodingNameFromEnvironment(
Tcl_DString *bufPtr)
{
UINT acp = GetACP();
Tcl_DStringInit(bufPtr);
if (acp == CP_UTF8) {
Tcl_DStringAppend(bufPtr, "utf-8", 5);
} else {
Tcl_DStringSetLength(bufPtr, 2+TCL_INTEGER_SPACE);
snprintf(Tcl_DStringValue(bufPtr), 2+TCL_INTEGER_SPACE, "cp%d", GetACP());
Tcl_DStringSetLength(bufPtr, strlen(Tcl_DStringValue(bufPtr)));
}
return Tcl_DStringValue(bufPtr);
}
const char *
TclpGetUserName(
Tcl_DString *bufferPtr) /* Uninitialized or free DString filled with
* the name of user. */
{
Tcl_DStringInit(bufferPtr);
if (TclGetEnv("USERNAME", bufferPtr) == NULL) {
WCHAR szUserName[UNLEN+1];
DWORD cchUserNameLen = UNLEN;
if (!GetUserNameW(szUserName, &cchUserNameLen)) {
return NULL;
}
cchUserNameLen--;
Tcl_DStringInit(bufferPtr);
Tcl_WCharToUtfDString(szUserName, cchUserNameLen, bufferPtr);
}
return Tcl_DStringValue(bufferPtr);
}
/*
*---------------------------------------------------------------------------
*
* 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;
Tcl_SetVar2Ex(interp, "tclDefaultLibrary", NULL,
TclGetProcessGlobalValue(&defaultLibraryDir), TCL_GLOBAL_ONLY);
if (!osInfoInitialized) {
HMODULE handle = GetModuleHandleW(L"NTDLL");
int(__stdcall *getversion)(void *) =
(int(__stdcall *)(void *))(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);
Tcl_SetVar2(interp, "tcl_platform", "os",
"Windows NT", TCL_GLOBAL_ONLY);
if (osInfo.dwMajorVersion == 10 && osInfo.dwBuildNumber >= 22000) {
osInfo.dwMajorVersion = 11;
}
snprintf(buffer, sizeof(buffer), "%ld.%ld", 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);
}
/*
* 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, TCL_INDEX_NONE);
}
ptr = Tcl_GetVar2(interp, "env", "HOMEPATH", TCL_GLOBAL_ONLY);
if (ptr != NULL) {
Tcl_DStringAppend(&ds, ptr, TCL_INDEX_NONE);
}
if (Tcl_DStringLength(&ds) > 0) {
Tcl_SetVar2(interp, "env", "HOME", Tcl_DStringValue(&ds),
TCL_GLOBAL_ONLY);
} else {
/* None of HOME, HOMEDRIVE, HOMEPATH exists. Try USERPROFILE */
ptr = Tcl_GetVar2(interp, "env", "USERPROFILE", TCL_GLOBAL_ONLY);
if (ptr != NULL && ptr[0]) {
Tcl_SetVar2(interp, "env", "HOME", ptr, TCL_GLOBAL_ONLY);
} else {
/* Last resort */
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.
*/
ptr = TclpGetUserName(&ds);
Tcl_SetVar2(interp, "tcl_platform", "user", ptr ? ptr : "",
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 mixed 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.
*
*----------------------------------------------------------------------
*/
# define tenviron2utfdstr(string, len, dsPtr) \
(char *)Tcl_Char16ToUtfDString((const unsigned short *)(string), ((((len) + 2) >> 1) - 1), (dsPtr))
Tcl_Size
TclpFindVariable(
const char *name, /* Name of desired environment variable
* (UTF-8). */
Tcl_Size *lengthPtr) /* Used to return length of name (for
* successful searches) or number of non-NULL
* entries in environ (for unsuccessful
* searches). */
{
Tcl_Size i, length, result = -1;
const WCHAR *env;
const char *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 *)Tcl_Alloc(length + 1);
memcpy(nameUpper, name, length+1);
Tcl_UtfToUpper(nameUpper);
Tcl_DStringInit(&envString);
for (i = 0, env = _wenviron[i];
env != NULL;
i++, env = _wenviron[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.
*/
Tcl_DStringInit(&envString);
envUpper = Tcl_WCharToUtfDString(env, -1, &envString);
p1 = strchr(envUpper, '=');
if (p1 == NULL) {
continue;
}
length = p1 - envUpper;
Tcl_DStringSetLength(&envString, length+1);
Tcl_UtfToUpper(envUpper);
p1 = envUpper;
p2 = nameUpper;
for (; *p2 == *p1; p1++, p2++) {
/* NULL loop body. */
}
if ((*p1 == '=') && (*p2 == '\0')) {
*lengthPtr = length;
result = i;
goto done;
}
Tcl_DStringFree(&envString);
}
*lengthPtr = i;
done:
Tcl_DStringFree(&envString);
Tcl_Free(nameUpper);
return result;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/