os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/win/tclWinInit.c
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/win/tclWinInit.c Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,916 @@
1.4 +/*
1.5 + * tclWinInit.c --
1.6 + *
1.7 + * Contains the Windows-specific interpreter initialization functions.
1.8 + *
1.9 + * Copyright (c) 1994-1997 Sun Microsystems, Inc.
1.10 + * Copyright (c) 1998-1999 by Scriptics Corporation.
1.11 + * All rights reserved.
1.12 + *
1.13 + * RCS: @(#) $Id: tclWinInit.c,v 1.40.2.6 2005/10/23 22:01:31 msofer Exp $
1.14 + */
1.15 +
1.16 +#include "tclWinInt.h"
1.17 +#include <winnt.h>
1.18 +#include <winbase.h>
1.19 +#include <lmcons.h>
1.20 +
1.21 +/*
1.22 + * The following declaration is a workaround for some Microsoft brain damage.
1.23 + * The SYSTEM_INFO structure is different in various releases, even though the
1.24 + * layout is the same. So we overlay our own structure on top of it so we
1.25 + * can access the interesting slots in a uniform way.
1.26 + */
1.27 +
1.28 +typedef struct {
1.29 + WORD wProcessorArchitecture;
1.30 + WORD wReserved;
1.31 +} OemId;
1.32 +
1.33 +/*
1.34 + * The following macros are missing from some versions of winnt.h.
1.35 + */
1.36 +
1.37 +#ifndef PROCESSOR_ARCHITECTURE_INTEL
1.38 +#define PROCESSOR_ARCHITECTURE_INTEL 0
1.39 +#endif
1.40 +#ifndef PROCESSOR_ARCHITECTURE_MIPS
1.41 +#define PROCESSOR_ARCHITECTURE_MIPS 1
1.42 +#endif
1.43 +#ifndef PROCESSOR_ARCHITECTURE_ALPHA
1.44 +#define PROCESSOR_ARCHITECTURE_ALPHA 2
1.45 +#endif
1.46 +#ifndef PROCESSOR_ARCHITECTURE_PPC
1.47 +#define PROCESSOR_ARCHITECTURE_PPC 3
1.48 +#endif
1.49 +#ifndef PROCESSOR_ARCHITECTURE_SHX
1.50 +#define PROCESSOR_ARCHITECTURE_SHX 4
1.51 +#endif
1.52 +#ifndef PROCESSOR_ARCHITECTURE_ARM
1.53 +#define PROCESSOR_ARCHITECTURE_ARM 5
1.54 +#endif
1.55 +#ifndef PROCESSOR_ARCHITECTURE_IA64
1.56 +#define PROCESSOR_ARCHITECTURE_IA64 6
1.57 +#endif
1.58 +#ifndef PROCESSOR_ARCHITECTURE_ALPHA64
1.59 +#define PROCESSOR_ARCHITECTURE_ALPHA64 7
1.60 +#endif
1.61 +#ifndef PROCESSOR_ARCHITECTURE_MSIL
1.62 +#define PROCESSOR_ARCHITECTURE_MSIL 8
1.63 +#endif
1.64 +#ifndef PROCESSOR_ARCHITECTURE_AMD64
1.65 +#define PROCESSOR_ARCHITECTURE_AMD64 9
1.66 +#endif
1.67 +#ifndef PROCESSOR_ARCHITECTURE_IA32_ON_WIN64
1.68 +#define PROCESSOR_ARCHITECTURE_IA32_ON_WIN64 10
1.69 +#endif
1.70 +#ifndef PROCESSOR_ARCHITECTURE_UNKNOWN
1.71 +#define PROCESSOR_ARCHITECTURE_UNKNOWN 0xFFFF
1.72 +#endif
1.73 +
1.74 +/*
1.75 + * The following arrays contain the human readable strings for the Windows
1.76 + * platform and processor values.
1.77 + */
1.78 +
1.79 +
1.80 +#define NUMPLATFORMS 4
1.81 +static char* platforms[NUMPLATFORMS] = {
1.82 + "Win32s", "Windows 95", "Windows NT", "Windows CE"
1.83 +};
1.84 +
1.85 +#define NUMPROCESSORS 11
1.86 +static char* processors[NUMPROCESSORS] = {
1.87 + "intel", "mips", "alpha", "ppc", "shx", "arm", "ia64", "alpha64", "msil",
1.88 + "amd64", "ia32_on_win64"
1.89 +};
1.90 +
1.91 +/* Used to store the encoding used for binary files */
1.92 +static Tcl_Encoding binaryEncoding = NULL;
1.93 +/* Has the basic library path encoding issue been fixed */
1.94 +static int libraryPathEncodingFixed = 0;
1.95 +
1.96 +/*
1.97 + * The Init script (common to Windows and Unix platforms) is
1.98 + * defined in tkInitScript.h
1.99 + */
1.100 +
1.101 +#include "tclInitScript.h"
1.102 +
1.103 +static void AppendEnvironment(Tcl_Obj *listPtr, CONST char *lib);
1.104 +static void AppendDllPath(Tcl_Obj *listPtr, HMODULE hModule,
1.105 + CONST char *lib);
1.106 +static int ToUtf(CONST WCHAR *wSrc, char *dst);
1.107 +
1.108 +/*
1.109 + *---------------------------------------------------------------------------
1.110 + *
1.111 + * TclpInitPlatform --
1.112 + *
1.113 + * Initialize all the platform-dependant things like signals and
1.114 + * floating-point error handling.
1.115 + *
1.116 + * Called at process initialization time.
1.117 + *
1.118 + * Results:
1.119 + * None.
1.120 + *
1.121 + * Side effects:
1.122 + * None.
1.123 + *
1.124 + *---------------------------------------------------------------------------
1.125 + */
1.126 +
1.127 +void
1.128 +TclpInitPlatform()
1.129 +{
1.130 + tclPlatform = TCL_PLATFORM_WINDOWS;
1.131 +
1.132 + /*
1.133 + * The following code stops Windows 3.X and Windows NT 3.51 from
1.134 + * automatically putting up Sharing Violation dialogs, e.g, when
1.135 + * someone tries to access a file that is locked or a drive with no
1.136 + * disk in it. Tcl already returns the appropriate error to the
1.137 + * caller, and they can decide to put up their own dialog in response
1.138 + * to that failure.
1.139 + *
1.140 + * Under 95 and NT 4.0, this is a NOOP because the system doesn't
1.141 + * automatically put up dialogs when the above operations fail.
1.142 + */
1.143 +
1.144 + SetErrorMode(SetErrorMode(0) | SEM_FAILCRITICALERRORS);
1.145 +
1.146 +#ifdef STATIC_BUILD
1.147 + /*
1.148 + * If we are in a statically linked executable, then we need to
1.149 + * explicitly initialize the Windows function tables here since
1.150 + * DllMain() will not be invoked.
1.151 + */
1.152 +
1.153 + TclWinInit(GetModuleHandle(NULL));
1.154 +#endif
1.155 +}
1.156 +
1.157 +/*
1.158 + *---------------------------------------------------------------------------
1.159 + *
1.160 + * TclpInitLibraryPath --
1.161 + *
1.162 + * Initialize the library path at startup.
1.163 + *
1.164 + * This call sets the library path to strings in UTF-8. Any
1.165 + * pre-existing library path information is assumed to have been
1.166 + * in the native multibyte encoding.
1.167 + *
1.168 + * Called at process initialization time.
1.169 + *
1.170 + * Results:
1.171 + * Return 0, indicating that the UTF is clean.
1.172 + *
1.173 + * Side effects:
1.174 + * None.
1.175 + *
1.176 + *---------------------------------------------------------------------------
1.177 + */
1.178 +
1.179 +int
1.180 +TclpInitLibraryPath(path)
1.181 + CONST char *path; /* Potentially dirty UTF string that is */
1.182 + /* the path to the executable name. */
1.183 +{
1.184 +#define LIBRARY_SIZE 32
1.185 + Tcl_Obj *pathPtr, *objPtr;
1.186 + CONST char *str;
1.187 + Tcl_DString ds;
1.188 + int pathc;
1.189 + CONST char **pathv;
1.190 + char installLib[LIBRARY_SIZE], developLib[LIBRARY_SIZE];
1.191 +
1.192 + Tcl_DStringInit(&ds);
1.193 + pathPtr = Tcl_NewObj();
1.194 +
1.195 + /*
1.196 + * Initialize the substrings used when locating an executable. The
1.197 + * installLib variable computes the path as though the executable
1.198 + * is installed. The developLib computes the path as though the
1.199 + * executable is run from a develpment directory.
1.200 + */
1.201 +
1.202 + sprintf(installLib, "lib/tcl%s", TCL_VERSION);
1.203 + sprintf(developLib, "tcl%s/library", TCL_PATCH_LEVEL);
1.204 +
1.205 + /*
1.206 + * Look for the library relative to default encoding dir.
1.207 + */
1.208 +
1.209 + str = Tcl_GetDefaultEncodingDir();
1.210 + if ((str != NULL) && (str[0] != '\0')) {
1.211 + objPtr = Tcl_NewStringObj(str, -1);
1.212 + Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
1.213 + }
1.214 +
1.215 + /*
1.216 + * Look for the library relative to the TCL_LIBRARY env variable.
1.217 + * If the last dirname in the TCL_LIBRARY path does not match the
1.218 + * last dirname in the installLib variable, use the last dir name
1.219 + * of installLib in addition to the orginal TCL_LIBRARY path.
1.220 + */
1.221 +
1.222 + AppendEnvironment(pathPtr, installLib);
1.223 +
1.224 + /*
1.225 + * Look for the library relative to the DLL. Only use the installLib
1.226 + * because in practice, the DLL is always installed.
1.227 + */
1.228 +
1.229 + AppendDllPath(pathPtr, TclWinGetTclInstance(), installLib);
1.230 +
1.231 +
1.232 + /*
1.233 + * Look for the library relative to the executable. This algorithm
1.234 + * should be the same as the one in the tcl_findLibrary procedure.
1.235 + *
1.236 + * This code looks in the following directories:
1.237 + *
1.238 + * <bindir>/../<installLib>
1.239 + * (e.g. /usr/local/bin/../lib/tcl8.4)
1.240 + * <bindir>/../../<installLib>
1.241 + * (e.g. /usr/local/TclPro/solaris-sparc/bin/../../lib/tcl8.4)
1.242 + * <bindir>/../library
1.243 + * (e.g. /usr/src/tcl8.4.0/unix/../library)
1.244 + * <bindir>/../../library
1.245 + * (e.g. /usr/src/tcl8.4.0/unix/solaris-sparc/../../library)
1.246 + * <bindir>/../../<developLib>
1.247 + * (e.g. /usr/src/tcl8.4.0/unix/../../tcl8.4.0/library)
1.248 + * <bindir>/../../../<developLib>
1.249 + * (e.g. /usr/src/tcl8.4.0/unix/solaris-sparc/../../../tcl8.4.0/library)
1.250 + */
1.251 +
1.252 + /*
1.253 + * The variable path holds an absolute path. Take care not to
1.254 + * overwrite pathv[0] since that might produce a relative path.
1.255 + */
1.256 +
1.257 + if (path != NULL) {
1.258 + int i, origc;
1.259 + CONST char **origv;
1.260 +
1.261 + Tcl_SplitPath(path, &origc, &origv);
1.262 + pathc = 0;
1.263 + pathv = (CONST char **) ckalloc((unsigned int)(origc * sizeof(char *)));
1.264 + for (i=0; i< origc; i++) {
1.265 + if (origv[i][0] == '.') {
1.266 + if (strcmp(origv[i], ".") == 0) {
1.267 + /* do nothing */
1.268 + } else if (strcmp(origv[i], "..") == 0) {
1.269 + pathc--;
1.270 + } else {
1.271 + pathv[pathc++] = origv[i];
1.272 + }
1.273 + } else {
1.274 + pathv[pathc++] = origv[i];
1.275 + }
1.276 + }
1.277 + if (pathc > 2) {
1.278 + str = pathv[pathc - 2];
1.279 + pathv[pathc - 2] = installLib;
1.280 + path = Tcl_JoinPath(pathc - 1, pathv, &ds);
1.281 + pathv[pathc - 2] = str;
1.282 + objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds));
1.283 + Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
1.284 + Tcl_DStringFree(&ds);
1.285 + }
1.286 + if (pathc > 3) {
1.287 + str = pathv[pathc - 3];
1.288 + pathv[pathc - 3] = installLib;
1.289 + path = Tcl_JoinPath(pathc - 2, pathv, &ds);
1.290 + pathv[pathc - 3] = str;
1.291 + objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds));
1.292 + Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
1.293 + Tcl_DStringFree(&ds);
1.294 + }
1.295 + if (pathc > 2) {
1.296 + str = pathv[pathc - 2];
1.297 + pathv[pathc - 2] = "library";
1.298 + path = Tcl_JoinPath(pathc - 1, pathv, &ds);
1.299 + pathv[pathc - 2] = str;
1.300 + objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds));
1.301 + Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
1.302 + Tcl_DStringFree(&ds);
1.303 + }
1.304 + if (pathc > 3) {
1.305 + str = pathv[pathc - 3];
1.306 + pathv[pathc - 3] = "library";
1.307 + path = Tcl_JoinPath(pathc - 2, pathv, &ds);
1.308 + pathv[pathc - 3] = str;
1.309 + objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds));
1.310 + Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
1.311 + Tcl_DStringFree(&ds);
1.312 + }
1.313 + if (pathc > 3) {
1.314 + str = pathv[pathc - 3];
1.315 + pathv[pathc - 3] = developLib;
1.316 + path = Tcl_JoinPath(pathc - 2, pathv, &ds);
1.317 + pathv[pathc - 3] = str;
1.318 + objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds));
1.319 + Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
1.320 + Tcl_DStringFree(&ds);
1.321 + }
1.322 + if (pathc > 4) {
1.323 + str = pathv[pathc - 4];
1.324 + pathv[pathc - 4] = developLib;
1.325 + path = Tcl_JoinPath(pathc - 3, pathv, &ds);
1.326 + pathv[pathc - 4] = str;
1.327 + objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds));
1.328 + Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
1.329 + Tcl_DStringFree(&ds);
1.330 + }
1.331 + ckfree((char *) origv);
1.332 + ckfree((char *) pathv);
1.333 + }
1.334 +
1.335 + TclSetLibraryPath(pathPtr);
1.336 +
1.337 + return 0; /* 0 indicates that pathPtr is clean (true) utf */
1.338 +}
1.339 +
1.340 +/*
1.341 + *---------------------------------------------------------------------------
1.342 + *
1.343 + * AppendEnvironment --
1.344 + *
1.345 + * Append the value of the TCL_LIBRARY environment variable onto the
1.346 + * path pointer. If the env variable points to another version of
1.347 + * tcl (e.g. "tcl7.6") also append the path to this version (e.g.,
1.348 + * "tcl7.6/../tcl8.2")
1.349 + *
1.350 + * Results:
1.351 + * None.
1.352 + *
1.353 + * Side effects:
1.354 + * None.
1.355 + *
1.356 + *---------------------------------------------------------------------------
1.357 + */
1.358 +
1.359 +static void
1.360 +AppendEnvironment(
1.361 + Tcl_Obj *pathPtr,
1.362 + CONST char *lib)
1.363 +{
1.364 + int pathc;
1.365 + WCHAR wBuf[MAX_PATH];
1.366 + char buf[MAX_PATH * TCL_UTF_MAX];
1.367 + Tcl_Obj *objPtr;
1.368 + Tcl_DString ds;
1.369 + CONST char **pathv;
1.370 + char *shortlib;
1.371 +
1.372 + /*
1.373 + * The shortlib value needs to be the tail component of the
1.374 + * lib path. For example, "lib/tcl8.4" -> "tcl8.4" while
1.375 + * "usr/share/tcl8.5" -> "tcl8.5".
1.376 + */
1.377 + for (shortlib = (char *) (lib + strlen(lib) - 1); shortlib > lib ; shortlib--) {
1.378 + if (*shortlib == '/') {
1.379 + if (shortlib == (lib + strlen(lib) - 1)) {
1.380 + Tcl_Panic("last character in lib cannot be '/'");
1.381 + }
1.382 + shortlib++;
1.383 + break;
1.384 + }
1.385 + }
1.386 + if (shortlib == lib) {
1.387 + Tcl_Panic("no '/' character found in lib");
1.388 + }
1.389 +
1.390 + /*
1.391 + * The "L" preceeding the TCL_LIBRARY string is used to tell VC++
1.392 + * that this is a unicode string.
1.393 + */
1.394 +
1.395 + if (GetEnvironmentVariableW(L"TCL_LIBRARY", wBuf, MAX_PATH) == 0) {
1.396 + buf[0] = '\0';
1.397 + GetEnvironmentVariableA("TCL_LIBRARY", buf, MAX_PATH);
1.398 + } else {
1.399 + ToUtf(wBuf, buf);
1.400 + }
1.401 +
1.402 + if (buf[0] != '\0') {
1.403 + objPtr = Tcl_NewStringObj(buf, -1);
1.404 + Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
1.405 +
1.406 + TclWinNoBackslash(buf);
1.407 + Tcl_SplitPath(buf, &pathc, &pathv);
1.408 +
1.409 + /*
1.410 + * The lstrcmpi() will work even if pathv[pathc - 1] is random
1.411 + * UTF-8 chars because I know shortlib is ascii.
1.412 + */
1.413 +
1.414 + if ((pathc > 0) && (lstrcmpiA(shortlib, pathv[pathc - 1]) != 0)) {
1.415 + CONST char *str;
1.416 + /*
1.417 + * TCL_LIBRARY is set but refers to a different tcl
1.418 + * installation than the current version. Try fiddling with the
1.419 + * specified directory to make it refer to this installation by
1.420 + * removing the old "tclX.Y" and substituting the current
1.421 + * version string.
1.422 + */
1.423 +
1.424 + pathv[pathc - 1] = shortlib;
1.425 + Tcl_DStringInit(&ds);
1.426 + str = Tcl_JoinPath(pathc, pathv, &ds);
1.427 + objPtr = Tcl_NewStringObj(str, Tcl_DStringLength(&ds));
1.428 + Tcl_DStringFree(&ds);
1.429 + } else {
1.430 + objPtr = Tcl_NewStringObj(buf, -1);
1.431 + }
1.432 + Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
1.433 + ckfree((char *) pathv);
1.434 + }
1.435 +}
1.436 +
1.437 +/*
1.438 + *---------------------------------------------------------------------------
1.439 + *
1.440 + * AppendDllPath --
1.441 + *
1.442 + * Append a path onto the path pointer that tries to locate the Tcl
1.443 + * library relative to the location of the Tcl DLL.
1.444 + *
1.445 + * Results:
1.446 + * None.
1.447 + *
1.448 + * Side effects:
1.449 + * None.
1.450 + *
1.451 + *---------------------------------------------------------------------------
1.452 + */
1.453 +
1.454 +static void
1.455 +AppendDllPath(
1.456 + Tcl_Obj *pathPtr,
1.457 + HMODULE hModule,
1.458 + CONST char *lib)
1.459 +{
1.460 + WCHAR wName[MAX_PATH + LIBRARY_SIZE];
1.461 + char name[(MAX_PATH + LIBRARY_SIZE) * TCL_UTF_MAX];
1.462 +
1.463 + if (GetModuleFileNameW(hModule, wName, MAX_PATH) == 0) {
1.464 + GetModuleFileNameA(hModule, name, MAX_PATH);
1.465 + } else {
1.466 + ToUtf(wName, name);
1.467 + }
1.468 + if (lib != NULL) {
1.469 + char *end, *p;
1.470 +
1.471 + end = strrchr(name, '\\');
1.472 + *end = '\0';
1.473 + p = strrchr(name, '\\');
1.474 + if (p != NULL) {
1.475 + end = p;
1.476 + }
1.477 + *end = '\\';
1.478 + strcpy(end + 1, lib);
1.479 + }
1.480 + TclWinNoBackslash(name);
1.481 + Tcl_ListObjAppendElement(NULL, pathPtr, Tcl_NewStringObj(name, -1));
1.482 +}
1.483 +
1.484 +/*
1.485 + *---------------------------------------------------------------------------
1.486 + *
1.487 + * ToUtf --
1.488 + *
1.489 + * Convert a char string to a UTF string.
1.490 + *
1.491 + * Results:
1.492 + * None.
1.493 + *
1.494 + * Side effects:
1.495 + * None.
1.496 + *
1.497 + *---------------------------------------------------------------------------
1.498 + */
1.499 +
1.500 +static int
1.501 +ToUtf(
1.502 + CONST WCHAR *wSrc,
1.503 + char *dst)
1.504 +{
1.505 + char *start;
1.506 +
1.507 + start = dst;
1.508 + while (*wSrc != '\0') {
1.509 + dst += Tcl_UniCharToUtf(*wSrc, dst);
1.510 + wSrc++;
1.511 + }
1.512 + *dst = '\0';
1.513 + return (int) (dst - start);
1.514 +}
1.515 +
1.516 +/*
1.517 + *---------------------------------------------------------------------------
1.518 + *
1.519 + * TclWinEncodingsCleanup --
1.520 + *
1.521 + * Reset information to its original state in finalization to
1.522 + * allow for reinitialization to be possible. This must not
1.523 + * be called until after the filesystem has been finalised, or
1.524 + * exit crashes may occur when using virtual filesystems.
1.525 + *
1.526 + * Results:
1.527 + * None.
1.528 + *
1.529 + * Side effects:
1.530 + * Static information reset to startup state.
1.531 + *
1.532 + *---------------------------------------------------------------------------
1.533 + */
1.534 +
1.535 +void
1.536 +TclWinEncodingsCleanup()
1.537 +{
1.538 + TclWinResetInterfaceEncodings();
1.539 + libraryPathEncodingFixed = 0;
1.540 + if (binaryEncoding != NULL) {
1.541 + Tcl_FreeEncoding(binaryEncoding);
1.542 + binaryEncoding = NULL;
1.543 + }
1.544 +}
1.545 +
1.546 +/*
1.547 + *---------------------------------------------------------------------------
1.548 + *
1.549 + * TclpSetInitialEncodings --
1.550 + *
1.551 + * Based on the locale, determine the encoding of the operating
1.552 + * system and the default encoding for newly opened files.
1.553 + *
1.554 + * Called at process initialization time, and part way through
1.555 + * startup, we verify that the initial encodings were correctly
1.556 + * setup. Depending on Tcl's environment, there may not have been
1.557 + * enough information first time through (above).
1.558 + *
1.559 + * Results:
1.560 + * None.
1.561 + *
1.562 + * Side effects:
1.563 + * The Tcl library path is converted from native encoding to UTF-8,
1.564 + * on the first call, and the encodings may be changed on first or
1.565 + * second call.
1.566 + *
1.567 + *---------------------------------------------------------------------------
1.568 + */
1.569 +
1.570 +void
1.571 +TclpSetInitialEncodings()
1.572 +{
1.573 + CONST char *encoding;
1.574 + char buf[4 + TCL_INTEGER_SPACE];
1.575 +
1.576 + if (libraryPathEncodingFixed == 0) {
1.577 + int platformId, useWide;
1.578 +
1.579 + platformId = TclWinGetPlatformId();
1.580 + useWide = ((platformId == VER_PLATFORM_WIN32_NT)
1.581 + || (platformId == VER_PLATFORM_WIN32_CE));
1.582 + TclWinSetInterfaces(useWide);
1.583 +
1.584 + wsprintfA(buf, "cp%d", GetACP());
1.585 + Tcl_SetSystemEncoding(NULL, buf);
1.586 +
1.587 + if (!useWide) {
1.588 + Tcl_Obj *pathPtr = TclGetLibraryPath();
1.589 + if (pathPtr != NULL) {
1.590 + int i, objc;
1.591 + Tcl_Obj **objv;
1.592 +
1.593 + objc = 0;
1.594 + Tcl_ListObjGetElements(NULL, pathPtr, &objc, &objv);
1.595 + for (i = 0; i < objc; i++) {
1.596 + int length;
1.597 + char *string;
1.598 + Tcl_DString ds;
1.599 +
1.600 + string = Tcl_GetStringFromObj(objv[i], &length);
1.601 + Tcl_ExternalToUtfDString(NULL, string, length, &ds);
1.602 + Tcl_SetStringObj(objv[i], Tcl_DStringValue(&ds),
1.603 + Tcl_DStringLength(&ds));
1.604 + Tcl_DStringFree(&ds);
1.605 + }
1.606 + }
1.607 + }
1.608 +
1.609 + libraryPathEncodingFixed = 1;
1.610 + } else {
1.611 + wsprintfA(buf, "cp%d", GetACP());
1.612 + Tcl_SetSystemEncoding(NULL, buf);
1.613 + }
1.614 +
1.615 + /* This is only ever called from the startup thread */
1.616 + if (binaryEncoding == NULL) {
1.617 + /*
1.618 + * Keep this encoding preloaded. The IO package uses it for
1.619 + * gets on a binary channel.
1.620 + */
1.621 + encoding = "iso8859-1";
1.622 + binaryEncoding = Tcl_GetEncoding(NULL, encoding);
1.623 + }
1.624 +}
1.625 +
1.626 +/*
1.627 + *---------------------------------------------------------------------------
1.628 + *
1.629 + * TclpSetVariables --
1.630 + *
1.631 + * Performs platform-specific interpreter initialization related to
1.632 + * the tcl_platform and env variables, and other platform-specific
1.633 + * things.
1.634 + *
1.635 + * Results:
1.636 + * None.
1.637 + *
1.638 + * Side effects:
1.639 + * Sets "tcl_platform", and "env(HOME)" Tcl variables.
1.640 + *
1.641 + *----------------------------------------------------------------------
1.642 + */
1.643 +
1.644 +void
1.645 +TclpSetVariables(interp)
1.646 + Tcl_Interp *interp; /* Interp to initialize. */
1.647 +{
1.648 + CONST char *ptr;
1.649 + char buffer[TCL_INTEGER_SPACE * 2];
1.650 + SYSTEM_INFO sysInfo;
1.651 + OemId *oemId;
1.652 + OSVERSIONINFOA osInfo;
1.653 + Tcl_DString ds;
1.654 + TCHAR szUserName[ UNLEN+1 ];
1.655 + DWORD dwUserNameLen = sizeof(szUserName);
1.656 +
1.657 + osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
1.658 + GetVersionExA(&osInfo);
1.659 +
1.660 + oemId = (OemId *) &sysInfo;
1.661 + GetSystemInfo(&sysInfo);
1.662 +
1.663 + /*
1.664 + * Define the tcl_platform array.
1.665 + */
1.666 +
1.667 + Tcl_SetVar2(interp, "tcl_platform", "platform", "windows",
1.668 + TCL_GLOBAL_ONLY);
1.669 + if (osInfo.dwPlatformId < NUMPLATFORMS) {
1.670 + Tcl_SetVar2(interp, "tcl_platform", "os",
1.671 + platforms[osInfo.dwPlatformId], TCL_GLOBAL_ONLY);
1.672 + }
1.673 + wsprintfA(buffer, "%d.%d", osInfo.dwMajorVersion, osInfo.dwMinorVersion);
1.674 + Tcl_SetVar2(interp, "tcl_platform", "osVersion", buffer, TCL_GLOBAL_ONLY);
1.675 + if (oemId->wProcessorArchitecture < NUMPROCESSORS) {
1.676 + Tcl_SetVar2(interp, "tcl_platform", "machine",
1.677 + processors[oemId->wProcessorArchitecture],
1.678 + TCL_GLOBAL_ONLY);
1.679 + }
1.680 +
1.681 +#ifdef _DEBUG
1.682 + /*
1.683 + * The existence of the "debug" element of the tcl_platform array indicates
1.684 + * that this particular Tcl shell has been compiled with debug information.
1.685 + * Using "info exists tcl_platform(debug)" a Tcl script can direct the
1.686 + * interpreter to load debug versions of DLLs with the load command.
1.687 + */
1.688 +
1.689 + Tcl_SetVar2(interp, "tcl_platform", "debug", "1",
1.690 + TCL_GLOBAL_ONLY);
1.691 +#endif
1.692 +
1.693 + /*
1.694 + * Set up the HOME environment variable from the HOMEDRIVE & HOMEPATH
1.695 + * environment variables, if necessary.
1.696 + */
1.697 +
1.698 + Tcl_DStringInit(&ds);
1.699 + ptr = Tcl_GetVar2(interp, "env", "HOME", TCL_GLOBAL_ONLY);
1.700 + if (ptr == NULL) {
1.701 + ptr = Tcl_GetVar2(interp, "env", "HOMEDRIVE", TCL_GLOBAL_ONLY);
1.702 + if (ptr != NULL) {
1.703 + Tcl_DStringAppend(&ds, ptr, -1);
1.704 + }
1.705 + ptr = Tcl_GetVar2(interp, "env", "HOMEPATH", TCL_GLOBAL_ONLY);
1.706 + if (ptr != NULL) {
1.707 + Tcl_DStringAppend(&ds, ptr, -1);
1.708 + }
1.709 + if (Tcl_DStringLength(&ds) > 0) {
1.710 + Tcl_SetVar2(interp, "env", "HOME", Tcl_DStringValue(&ds),
1.711 + TCL_GLOBAL_ONLY);
1.712 + } else {
1.713 + Tcl_SetVar2(interp, "env", "HOME", "c:\\", TCL_GLOBAL_ONLY);
1.714 + }
1.715 + }
1.716 +
1.717 + /*
1.718 + * Initialize the user name from the environment first, since this is much
1.719 + * faster than asking the system.
1.720 + */
1.721 +
1.722 + Tcl_DStringInit( &ds );
1.723 + if (TclGetEnv("USERNAME", &ds) == NULL) {
1.724 +
1.725 + if ( GetUserName( szUserName, &dwUserNameLen ) != 0 ) {
1.726 + Tcl_WinTCharToUtf( szUserName, dwUserNameLen, &ds );
1.727 + }
1.728 + }
1.729 + Tcl_SetVar2(interp, "tcl_platform", "user", Tcl_DStringValue(&ds),
1.730 + TCL_GLOBAL_ONLY);
1.731 + Tcl_DStringFree(&ds);
1.732 +}
1.733 +
1.734 +/*
1.735 + *----------------------------------------------------------------------
1.736 + *
1.737 + * TclpFindVariable --
1.738 + *
1.739 + * Locate the entry in environ for a given name. On Unix this
1.740 + * routine is case sensetive, on Windows this matches mioxed case.
1.741 + *
1.742 + * Results:
1.743 + * The return value is the index in environ of an entry with the
1.744 + * name "name", or -1 if there is no such entry. The integer at
1.745 + * *lengthPtr is filled in with the length of name (if a matching
1.746 + * entry is found) or the length of the environ array (if no matching
1.747 + * entry is found).
1.748 + *
1.749 + * Side effects:
1.750 + * None.
1.751 + *
1.752 + *----------------------------------------------------------------------
1.753 + */
1.754 +
1.755 +int
1.756 +TclpFindVariable(name, lengthPtr)
1.757 + CONST char *name; /* Name of desired environment variable
1.758 + * (UTF-8). */
1.759 + int *lengthPtr; /* Used to return length of name (for
1.760 + * successful searches) or number of non-NULL
1.761 + * entries in environ (for unsuccessful
1.762 + * searches). */
1.763 +{
1.764 + int i, length, result = -1;
1.765 + register CONST char *env, *p1, *p2;
1.766 + char *envUpper, *nameUpper;
1.767 + Tcl_DString envString;
1.768 +
1.769 + /*
1.770 + * Convert the name to all upper case for the case insensitive
1.771 + * comparison.
1.772 + */
1.773 +
1.774 + length = strlen(name);
1.775 + nameUpper = (char *) ckalloc((unsigned) length+1);
1.776 + memcpy((VOID *) nameUpper, (VOID *) name, (size_t) length+1);
1.777 + Tcl_UtfToUpper(nameUpper);
1.778 +
1.779 + Tcl_DStringInit(&envString);
1.780 + for (i = 0, env = environ[i]; env != NULL; i++, env = environ[i]) {
1.781 + /*
1.782 + * Chop the env string off after the equal sign, then Convert
1.783 + * the name to all upper case, so we do not have to convert
1.784 + * all the characters after the equal sign.
1.785 + */
1.786 +
1.787 + envUpper = Tcl_ExternalToUtfDString(NULL, env, -1, &envString);
1.788 + p1 = strchr(envUpper, '=');
1.789 + if (p1 == NULL) {
1.790 + continue;
1.791 + }
1.792 + length = (int) (p1 - envUpper);
1.793 + Tcl_DStringSetLength(&envString, length+1);
1.794 + Tcl_UtfToUpper(envUpper);
1.795 +
1.796 + p1 = envUpper;
1.797 + p2 = nameUpper;
1.798 + for (; *p2 == *p1; p1++, p2++) {
1.799 + /* NULL loop body. */
1.800 + }
1.801 + if ((*p1 == '=') && (*p2 == '\0')) {
1.802 + *lengthPtr = length;
1.803 + result = i;
1.804 + goto done;
1.805 + }
1.806 +
1.807 + Tcl_DStringFree(&envString);
1.808 + }
1.809 +
1.810 + *lengthPtr = i;
1.811 +
1.812 + done:
1.813 + Tcl_DStringFree(&envString);
1.814 + ckfree(nameUpper);
1.815 + return result;
1.816 +}
1.817 +
1.818 +/*
1.819 + *----------------------------------------------------------------------
1.820 + *
1.821 + * Tcl_Init --
1.822 + *
1.823 + * This procedure is typically invoked by Tcl_AppInit procedures
1.824 + * to perform additional initialization for a Tcl interpreter,
1.825 + * such as sourcing the "init.tcl" script.
1.826 + *
1.827 + * Results:
1.828 + * Returns a standard Tcl completion code and sets the interp's
1.829 + * result if there is an error.
1.830 + *
1.831 + * Side effects:
1.832 + * Depends on what's in the init.tcl script.
1.833 + *
1.834 + *----------------------------------------------------------------------
1.835 + */
1.836 +
1.837 +int
1.838 +Tcl_Init(interp)
1.839 + Tcl_Interp *interp; /* Interpreter to initialize. */
1.840 +{
1.841 + Tcl_Obj *pathPtr;
1.842 +
1.843 + if (tclPreInitScript != NULL) {
1.844 + if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) {
1.845 + return (TCL_ERROR);
1.846 + };
1.847 + }
1.848 +
1.849 + pathPtr = TclGetLibraryPath();
1.850 + if (pathPtr == NULL) {
1.851 + pathPtr = Tcl_NewObj();
1.852 + }
1.853 + Tcl_IncrRefCount(pathPtr);
1.854 + Tcl_SetVar2Ex(interp, "tcl_libPath", NULL, pathPtr, TCL_GLOBAL_ONLY);
1.855 + Tcl_DecrRefCount(pathPtr);
1.856 + return Tcl_Eval(interp, initScript);
1.857 +}
1.858 +
1.859 +/*
1.860 + *----------------------------------------------------------------------
1.861 + *
1.862 + * Tcl_SourceRCFile --
1.863 + *
1.864 + * This procedure is typically invoked by Tcl_Main of Tk_Main
1.865 + * procedure to source an application specific rc file into the
1.866 + * interpreter at startup time.
1.867 + *
1.868 + * Results:
1.869 + * None.
1.870 + *
1.871 + * Side effects:
1.872 + * Depends on what's in the rc script.
1.873 + *
1.874 + *----------------------------------------------------------------------
1.875 + */
1.876 +
1.877 +void
1.878 +Tcl_SourceRCFile(interp)
1.879 + Tcl_Interp *interp; /* Interpreter to source rc file into. */
1.880 +{
1.881 + Tcl_DString temp;
1.882 + CONST char *fileName;
1.883 + Tcl_Channel errChannel;
1.884 +
1.885 + fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY);
1.886 +
1.887 + if (fileName != NULL) {
1.888 + Tcl_Channel c;
1.889 + CONST char *fullName;
1.890 +
1.891 + Tcl_DStringInit(&temp);
1.892 + fullName = Tcl_TranslateFileName(interp, fileName, &temp);
1.893 + if (fullName == NULL) {
1.894 + /*
1.895 + * Couldn't translate the file name (e.g. it referred to a
1.896 + * bogus user or there was no HOME environment variable).
1.897 + * Just do nothing.
1.898 + */
1.899 + } else {
1.900 +
1.901 + /*
1.902 + * Test for the existence of the rc file before trying to read it.
1.903 + */
1.904 +
1.905 + c = Tcl_OpenFileChannel(NULL, fullName, "r", 0);
1.906 + if (c != (Tcl_Channel) NULL) {
1.907 + Tcl_Close(NULL, c);
1.908 + if (Tcl_EvalFile(interp, fullName) != TCL_OK) {
1.909 + errChannel = Tcl_GetStdChannel(TCL_STDERR);
1.910 + if (errChannel) {
1.911 + Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
1.912 + Tcl_WriteChars(errChannel, "\n", 1);
1.913 + }
1.914 + }
1.915 + }
1.916 + }
1.917 + Tcl_DStringFree(&temp);
1.918 + }
1.919 +}