path: root/win/tclWinInit.c

/* 
 * 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.55 2004/06/17 21:43:56 dgp Exp $
 */

#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

/*
 * 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"
};

/* Used to store the encoding used for binary files */
static Tcl_Encoding binaryEncoding = NULL;
/* Has the basic library path encoding issue been fixed */
static int libraryPathEncodingFixed = 0;

static void		AppendEnvironment(Tcl_Obj *listPtr, CONST char *lib);
static void		AppendDllPath(Tcl_Obj *listPtr, HMODULE hModule,
			    CONST char *lib);
static void		FreeDefaultLibraryDir(ClientData);
static void		FreeThreadDefaultLibraryDir(ClientData);
static Tcl_Obj *	GetDefaultLibraryDir();
static void		SetDefaultLibraryDir(Tcl_Obj *directory);
static int		ToUtf(CONST WCHAR *wSrc, char *dst);

/*
 *---------------------------------------------------------------------------
 *
 * SetDefaultLibraryDir --
 *
 *	Called by TclpInitLibraryPath to save the path to the
 *	directory ../lib/tcl<version> relative to the Tcl Dll.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Saves a per-thread (Tcl_Obj *) and a per-process string.
 *	Sets up exit handlers to free them.
 *
 *---------------------------------------------------------------------------
 */

/*
 * Per-process copy of the default library dir, as a string, shared by
 * all threads
 */
static char *defaultLibraryDir = NULL;
static int defaultLibraryDirLength = 0;
static Tcl_ThreadDataKey defaultLibraryDirKey;

static void
FreeThreadDefaultLibraryDir(clientData)
    ClientData clientData;
{
    Tcl_Obj **objPtrPtr = (Tcl_Obj **) clientData;
    Tcl_DecrRefCount(*objPtrPtr);
}

static void
FreeDefaultLibraryDir(clientData)
    ClientData clientData;
{
    ckfree(defaultLibraryDir);
    defaultLibraryDir = NULL;
    defaultLibraryDirLength = 0;
}

static void
SetDefaultLibraryDir(directory)
    Tcl_Obj *directory;
{
    CONST char *bytes;
    Tcl_Obj **savedDirectoryPtr = (Tcl_Obj **)
	    Tcl_GetThreadData(&defaultLibraryDirKey, (int)sizeof(Tcl_Obj *));

    Tcl_IncrRefCount(directory);
    if (NULL == *savedDirectoryPtr) {
	/* First call in this thread, set up the thread exit handler */
	Tcl_CreateThreadExitHandler(FreeThreadDefaultLibraryDir,
		(ClientData) savedDirectoryPtr);
    } else {
	/* Called SetDLD after a previous SetDLD or GetDLD in this thread ?! */
	Tcl_DecrRefCount(*savedDirectoryPtr);
    }
    *savedDirectoryPtr = directory;

    /* No Mutex protection, as the only caller is already in TclpInitLock */

    if (NULL == defaultLibraryDir) {
	/* First call from any thread; set up exit handler */
	Tcl_CreateExitHandler(FreeDefaultLibraryDir, NULL);
    } else {
	Tcl_Panic("Double initialization of DefaultLibraryDir?!");
    }
    bytes = Tcl_GetStringFromObj(directory, &defaultLibraryDirLength);
    defaultLibraryDir = ckalloc((unsigned int) defaultLibraryDirLength+1);
    memcpy(defaultLibraryDir, bytes, (unsigned int) defaultLibraryDirLength+1);
}

/*
 *---------------------------------------------------------------------------
 *
 * GetDefaultLibraryDir --
 *
 *	Called by TclpSetVariables to retrieve the saved value
 *	stored by SetDefaultLibraryDir in order to store that value
 *	in ::tclDefaultLibrary .
 *
 * Results:
 *	A pointer to a Tcl_Obj holding the default directory path
 *	for init.tcl.
 *
 * Side effects:
 *
 *---------------------------------------------------------------------------
 */

static Tcl_Obj *
GetDefaultLibraryDir()
{
    Tcl_Obj **savedDirectoryPtr = (Tcl_Obj **)
	    Tcl_GetThreadData(&defaultLibraryDirKey, (int)sizeof(Tcl_Obj *));

    if (NULL != *savedDirectoryPtr) {
	return *savedDirectoryPtr;
    }

    if (NULL == defaultLibraryDir) {
	/*
	 * Careful here.  This may be bogus, calling TclpInitLibraryPath
	 * when not in TclpInitLock.  OTOH, this branch shouldn't happen.
	 */
	TclpInitLibraryPath(NULL);
	if (NULL != *savedDirectoryPtr) {
	    return *savedDirectoryPtr;
	} else {
	    Tcl_Panic("TclpInitLibraryPath failed to set default library dir");
	}
    }

    *savedDirectoryPtr =
	    Tcl_NewStringObj(defaultLibraryDir, defaultLibraryDirLength);
    Tcl_IncrRefCount(*savedDirectoryPtr);
    Tcl_CreateThreadExitHandler(FreeThreadDefaultLibraryDir,
		(ClientData) savedDirectoryPtr);
    return *savedDirectoryPtr;
}

/*
 *---------------------------------------------------------------------------
 *
 * 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 --
 *
 *	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.
 *
 * Results:
 *	Return 0, indicating that the UTF is clean.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

int
TclpInitLibraryPath(path)
    CONST char *path;		/* Potentially dirty UTF string that is */
				/* the path to the executable name.     */
{
#define LIBRARY_SIZE	    32
    Tcl_Obj *pathPtr, *objPtr, **objv;
    CONST char *str;
    Tcl_DString ds;
    int objc, pathc;
    CONST char **pathv;
    char installLib[LIBRARY_SIZE], developLib[LIBRARY_SIZE];

    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.
     */

    sprintf(installLib, "lib/tcl%s", TCL_VERSION);
    sprintf(developLib, "tcl%s/library", TCL_PATCH_LEVEL);

    /*
     * 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.
     */

    AppendEnvironment(pathPtr, installLib);

    /*
     * Look for the library relative to the DLL.  Only use the installLib
     * because in practice, the DLL is always installed.
     */

    AppendDllPath(pathPtr, TclWinGetTclInstance(), installLib);

    Tcl_ListObjGetElements(NULL, pathPtr, &objc, &objv);
    SetDefaultLibraryDir(objv[objc-1]);

    /*
     * 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.4)
     *	<bindir>/../../<installLib>
     * 	  (e.g. /usr/local/TclPro/solaris-sparc/bin/../../lib/tcl8.4)
     *	<bindir>/../library
     * 	  (e.g. /usr/src/tcl8.4.0/unix/../library)
     *	<bindir>/../../library
     *	  (e.g. /usr/src/tcl8.4.0/unix/solaris-sparc/../../library)
     *	<bindir>/../../<developLib>
     *	  (e.g. /usr/src/tcl8.4.0/unix/../../tcl8.4.0/library)
     *	<bindir>/../../../<developLib>
     *	   (e.g. /usr/src/tcl8.4.0/unix/solaris-sparc/../../../tcl8.4.0/library)
     */
     
    /*
     * The variable path holds an absolute path.  Take care not to
     * overwrite pathv[0] since that might produce a relative path.
     */

    if (0 && path != NULL) {
	int i, origc;
	CONST char **origv;

	Tcl_SplitPath(path, &origc, &origv);
	pathc = 0;
	pathv = (CONST char **) ckalloc((unsigned int)(origc * sizeof(char *)));
	for (i=0; i< origc; i++) {
	    if (origv[i][0] == '.') {
		if (strcmp(origv[i], ".") == 0) {
		    /* do nothing */
		} else if (strcmp(origv[i], "..") == 0) {
		    pathc--;
		} else {
		    pathv[pathc++] = origv[i];
		}
	    } else {
		pathv[pathc++] = origv[i];
	    }
	}
	if (pathc > 2) {
	    str = pathv[pathc - 2];
	    pathv[pathc - 2] = installLib;
	    path = Tcl_JoinPath(pathc - 1, pathv, &ds);
	    pathv[pathc - 2] = str;
	    objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds));
	    Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
	    Tcl_DStringFree(&ds);
	}
	if (pathc > 3) {
	    str = pathv[pathc - 3];
	    pathv[pathc - 3] = installLib;
	    path = Tcl_JoinPath(pathc - 2, pathv, &ds);
	    pathv[pathc - 3] = str;
	    objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds));
	    Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
	    Tcl_DStringFree(&ds);
	}
	if (pathc > 2) {
	    str = pathv[pathc - 2];
	    pathv[pathc - 2] = "library";
	    path = Tcl_JoinPath(pathc - 1, pathv, &ds);
	    pathv[pathc - 2] = str;
	    objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds));
	    Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
	    Tcl_DStringFree(&ds);
	}
	if (pathc > 3) {
	    str = pathv[pathc - 3];
	    pathv[pathc - 3] = "library";
	    path = Tcl_JoinPath(pathc - 2, pathv, &ds);
	    pathv[pathc - 3] = str;
	    objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds));
	    Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
	    Tcl_DStringFree(&ds);
	}
	if (pathc > 3) {
	    str = pathv[pathc - 3];
	    pathv[pathc - 3] = developLib;
	    path = Tcl_JoinPath(pathc - 2, pathv, &ds);
	    pathv[pathc - 3] = str;
	    objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds));
	    Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
	    Tcl_DStringFree(&ds);
	}
	if (pathc > 4) {
	    str = pathv[pathc - 4];
	    pathv[pathc - 4] = developLib;
	    path = Tcl_JoinPath(pathc - 3, pathv, &ds);
	    pathv[pathc - 4] = str;
	    objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds));
	    Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
	    Tcl_DStringFree(&ds);
	}
	ckfree((char *) origv);
	ckfree((char *) pathv);
    }

    TclSetLibraryPath(pathPtr);

    return 0; /* 0 indicates that pathPtr is clean (true) utf */
}

/*
 *---------------------------------------------------------------------------
 *
 * 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 (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);
    }
}

/*
 *---------------------------------------------------------------------------
 *
 * AppendDllPath --
 *
 *	Append a path onto the path pointer that tries to locate the Tcl
 *	library relative to the location of the Tcl DLL.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

static void 
AppendDllPath(
    Tcl_Obj *pathPtr, 
    HMODULE hModule,
    CONST char *lib)
{
    WCHAR wName[MAX_PATH + LIBRARY_SIZE];
    char name[(MAX_PATH + LIBRARY_SIZE) * TCL_UTF_MAX];

    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);
    }
    TclWinNoBackslash(name);
    Tcl_ListObjAppendElement(NULL, pathPtr, Tcl_NewStringObj(name, -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();
    libraryPathEncodingFixed = 0;
    if (binaryEncoding != NULL) {
	Tcl_FreeEncoding(binaryEncoding);
	binaryEncoding = NULL;
    }
}

/*
 *---------------------------------------------------------------------------
 *
 * 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()
{
    CONST char *encoding;
    char buf[4 + TCL_INTEGER_SPACE];

    if (libraryPathEncodingFixed == 0) {
	int platformId, useWide;

	platformId = TclWinGetPlatformId();
	useWide = ((platformId == VER_PLATFORM_WIN32_NT)
		|| (platformId == VER_PLATFORM_WIN32_CE));
	TclWinSetInterfaces(useWide);
	
	wsprintfA(buf, "cp%d", GetACP());
	Tcl_SetSystemEncoding(NULL, buf);

	if (!useWide) {
	    Tcl_Obj *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);
		}
	    }
	}
	
	libraryPathEncodingFixed = 1;
    } else {
	wsprintfA(buf, "cp%d", GetACP());
	Tcl_SetSystemEncoding(NULL, buf);
    }

    /* This is only ever called from the startup thread */
    if (binaryEncoding == NULL) {
	/*
	 * Keep this encoding preloaded.  The IO package uses it for
	 * gets on a binary channel.
	 */
	encoding = "iso8859-1";
	binaryEncoding = Tcl_GetEncoding(NULL, encoding);
    }
}

/*
 *---------------------------------------------------------------------------
 *
 * 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,
	    GetDefaultLibraryDir(), 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;
}