summaryrefslogtreecommitdiffstats
path: root/win/tclWinInit.c
diff options
context:
space:
mode:
Diffstat (limited to 'win/tclWinInit.c')
-rw-r--r--win/tclWinInit.c667
1 files changed, 216 insertions, 451 deletions
diff --git a/win/tclWinInit.c b/win/tclWinInit.c
index acaf705..a1087c9 100644
--- a/win/tclWinInit.c
+++ b/win/tclWinInit.c
@@ -1,4 +1,4 @@
-/*
+/*
* tclWinInit.c --
*
* Contains the Windows-specific interpreter initialization functions.
@@ -6,6 +6,9 @@
* 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"
@@ -14,10 +17,17 @@
#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.
+ * 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 {
@@ -30,40 +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
+#ifndef PROCESSOR_ARCHITECTURE_SHX
+#define PROCESSOR_ARCHITECTURE_SHX 4
#endif
#ifndef PROCESSOR_ARCHITECTURE_ARM
-#define PROCESSOR_ARCHITECTURE_ARM 5
+#define PROCESSOR_ARCHITECTURE_ARM 5
#endif
#ifndef PROCESSOR_ARCHITECTURE_IA64
-#define PROCESSOR_ARCHITECTURE_IA64 6
+#define PROCESSOR_ARCHITECTURE_IA64 6
#endif
#ifndef PROCESSOR_ARCHITECTURE_ALPHA64
-#define PROCESSOR_ARCHITECTURE_ALPHA64 7
+#define PROCESSOR_ARCHITECTURE_ALPHA64 7
#endif
#ifndef PROCESSOR_ARCHITECTURE_MSIL
-#define PROCESSOR_ARCHITECTURE_MSIL 8
+#define PROCESSOR_ARCHITECTURE_MSIL 8
#endif
#ifndef PROCESSOR_ARCHITECTURE_AMD64
-#define PROCESSOR_ARCHITECTURE_AMD64 9
+#define PROCESSOR_ARCHITECTURE_AMD64 9
#endif
#ifndef PROCESSOR_ARCHITECTURE_IA32_ON_WIN64
-#define PROCESSOR_ARCHITECTURE_IA32_ON_WIN64 10
+#define PROCESSOR_ARCHITECTURE_IA32_ON_WIN64 10
#endif
#ifndef PROCESSOR_ARCHITECTURE_UNKNOWN
-#define PROCESSOR_ARCHITECTURE_UNKNOWN 0xFFFF
+#define PROCESSOR_ARCHITECTURE_UNKNOWN 0xFFFF
#endif
/*
@@ -83,21 +93,15 @@ static char* processors[NUMPROCESSORS] = {
"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;
-
/*
- * The Init script (common to Windows and Unix platforms) is
- * defined in tkInitScript.h
+ * The default directory in which the init.tcl file is expected to be found.
*/
-#include "tclInitScript.h"
+static TclInitProcessGlobalValueProc InitializeDefaultLibraryDir;
+static ProcessGlobalValue defaultLibraryDir =
+ {0, 0, NULL, NULL, InitializeDefaultLibraryDir, 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);
/*
@@ -120,19 +124,18 @@ static int ToUtf(CONST WCHAR *wSrc, char *dst);
*/
void
-TclpInitPlatform()
+TclpInitPlatform(void)
{
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.
+ * 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
+ * Under 95 and NT 4.0, this is a NOOP because the system doesn't
* automatically put up dialogs when the above operations fail.
*/
@@ -140,9 +143,9 @@ TclpInitPlatform()
#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,186 +153,64 @@ 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:
- * Return 0, indicating that the UTF is clean.
+ * None.
*
* Side effects:
- * None.
+ * Sets the library path to an initial value.
*
- *---------------------------------------------------------------------------
+ *-------------------------------------------------------------------------
*/
-int
-TclpInitLibraryPath(path)
- CONST char *path; /* Potentially dirty UTF string that is */
- /* the path to the executable name. */
+void
+TclpInitLibraryPath(
+ char **valuePtr,
+ int *lengthPtr,
+ Tcl_Encoding *encodingPtr)
{
#define LIBRARY_SIZE 32
- Tcl_Obj *pathPtr, *objPtr;
- CONST char *str;
- Tcl_DString ds;
- int pathc;
- CONST char **pathv;
- char installLib[LIBRARY_SIZE], developLib[LIBRARY_SIZE];
+ Tcl_Obj *pathPtr;
+ char installLib[LIBRARY_SIZE];
+ 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_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.
+ * 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.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 (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 */
+ *encodingPtr = NULL;
+ bytes = Tcl_GetStringFromObj(pathPtr, lengthPtr);
+ *valuePtr = ckalloc((unsigned int)(*lengthPtr)+1);
+ memcpy(*valuePtr, bytes, (size_t)(*lengthPtr)+1);
+ Tcl_DecrRefCount(pathPtr);
}
/*
@@ -337,9 +218,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:
@@ -365,30 +246,30 @@ AppendEnvironment(
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".
+ * 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;
- }
+
+ 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");
+ 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.
+ * 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);
@@ -401,21 +282,21 @@ 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 shortlib 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(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.
+ * 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);
@@ -432,10 +313,10 @@ AppendEnvironment(
/*
*---------------------------------------------------------------------------
*
- * 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.
@@ -446,34 +327,37 @@ 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);
- Tcl_ListObjAppendElement(NULL, pathPtr, Tcl_NewStringObj(name, -1));
+ sprintf(end + 1, "lib/tcl%s", TCL_VERSION);
+ *lengthPtr = strlen(name);
+ *valuePtr = ckalloc((unsigned int) *lengthPtr + 1);
+ *encodingPtr = NULL;
+ memcpy(*valuePtr, name, (size_t) *lengthPtr + 1);
}
/*
@@ -481,7 +365,7 @@ AppendDllPath(
*
* ToUtf --
*
- * Convert a char string to a UTF string.
+ * Convert a char string to a UTF string.
*
* Results:
* None.
@@ -513,10 +397,10 @@ ToUtf(
*
* 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.
+ * 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.
@@ -528,14 +412,9 @@ ToUtf(
*/
void
-TclWinEncodingsCleanup()
+TclWinEncodingsCleanup(void)
{
TclWinResetInterfaceEncodings();
- libraryPathEncodingFixed = 0;
- if (binaryEncoding != NULL) {
- Tcl_FreeEncoding(binaryEncoding);
- binaryEncoding = NULL;
- }
}
/*
@@ -543,79 +422,56 @@ TclWinEncodingsCleanup()
*
* 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, 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).
+ * 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.
+ * 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];
-
- 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);
- }
+ Tcl_DString encodingName;
- /* 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);
- }
+ TclpSetInterfaces();
+ Tcl_SetSystemEncoding(NULL,
+ Tcl_GetEncodingNameFromEnvironment(&encodingName));
+ Tcl_DStringFree(&encodingName);
+}
+
+void
+TclpSetInterfaces(void)
+{
+ int platformId, useWide;
+
+ platformId = TclWinGetPlatformId();
+ useWide = ((platformId == VER_PLATFORM_WIN32_NT)
+ || (platformId == VER_PLATFORM_WIN32_CE));
+ TclWinSetInterfaces(useWide);
+}
+
+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);
}
/*
@@ -623,9 +479,8 @@ 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.
@@ -637,23 +492,27 @@ TclpSetInitialEncodings()
*/
void
-TclpSetVariables(interp)
- Tcl_Interp *interp; /* Interp to initialize. */
-{
+TclpSetVariables(
+ Tcl_Interp *interp) /* Interp to initialize. */
+{
CONST char *ptr;
char buffer[TCL_INTEGER_SPACE * 2];
- SYSTEM_INFO sysInfo;
- OemId *oemId;
+ union {
+ SYSTEM_INFO info;
+ OemId oemId;
+ } sys;
OSVERSIONINFOA osInfo;
Tcl_DString ds;
- TCHAR szUserName[ UNLEN+1 ];
- DWORD dwUserNameLen = sizeof(szUserName);
+ WCHAR szUserName[UNLEN+1];
+ DWORD cchUserNameLen = UNLEN;
+
+ Tcl_SetVar2Ex(interp, "tclDefaultLibrary", NULL,
+ TclGetProcessGlobalValue(&defaultLibraryDir), TCL_GLOBAL_ONLY);
osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
GetVersionExA(&osInfo);
- oemId = (OemId *) &sysInfo;
- GetSystemInfo(&sysInfo);
+ GetSystemInfo(&sys.info);
/*
* Define the tcl_platform array.
@@ -667,18 +526,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",
@@ -712,14 +572,16 @@ 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_DStringInit( &ds );
+ Tcl_DStringInit(&ds);
if (TclGetEnv("USERNAME", &ds) == NULL) {
-
- if ( GetUserName( szUserName, &dwUserNameLen ) != 0 ) {
- Tcl_WinTCharToUtf( szUserName, dwUserNameLen, &ds );
- }
+ if (tclWinProcs->getUserName((LPTSTR)szUserName, &cchUserNameLen) != 0) {
+ int cbUserNameLen = cchUserNameLen - 1;
+ if (tclWinProcs->useWide) cbUserNameLen *= sizeof(WCHAR);
+ Tcl_WinTCharToUtf((LPTSTR)szUserName, cbUserNameLen, &ds);
+ }
}
Tcl_SetVar2(interp, "tcl_platform", "user", Tcl_DStringValue(&ds),
TCL_GLOBAL_ONLY);
@@ -731,15 +593,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.
@@ -748,10 +609,10 @@ 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). */
@@ -762,23 +623,22 @@ TclpFindVariable(name, lengthPtr)
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);
+ 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) {
@@ -798,117 +658,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_IncrRefCount(pathPtr);
- Tcl_SetVar2Ex(interp, "tcl_libPath", NULL, pathPtr, TCL_GLOBAL_ONLY);
- Tcl_DecrRefCount(pathPtr);
- 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.
- *
- *----------------------------------------------------------------------
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
*/
-
-void
-Tcl_SourceRCFile(interp)
- Tcl_Interp *interp; /* Interpreter to source rc file into. */
-{
- Tcl_DString temp;
- CONST char *fileName;
- Tcl_Channel errChannel;
-
- fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY);
-
- if (fileName != NULL) {
- Tcl_Channel c;
- CONST 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);
- }
-}