1/* 2 * tclWinInit.c -- 3 * 4 * Contains the Windows-specific interpreter initialization functions. 5 * 6 * Copyright (c) 1994-1997 Sun Microsystems, Inc. 7 * Copyright (c) 1998-1999 by Scriptics Corporation. 8 * All rights reserved. 9 * 10 * See the file "license.terms" for information on usage and redistribution of 11 * this file, and for a DISCLAIMER OF ALL WARRANTIES. 12 * 13 * RCS: @(#) $Id: tclWinInit.c,v 1.75.2.1 2009/07/01 14:05:19 patthoyts Exp $ 14 */ 15 16#include "tclWinInt.h" 17#include <winnt.h> 18#include <winbase.h> 19#include <lmcons.h> 20 21/* 22 * GetUserName() is found in advapi32.dll 23 */ 24#ifdef _MSC_VER 25# pragma comment(lib, "advapi32.lib") 26#endif 27 28/* 29 * The following declaration is a workaround for some Microsoft brain damage. 30 * The SYSTEM_INFO structure is different in various releases, even though the 31 * layout is the same. So we overlay our own structure on top of it so we can 32 * access the interesting slots in a uniform way. 33 */ 34 35typedef struct { 36 WORD wProcessorArchitecture; 37 WORD wReserved; 38} OemId; 39 40/* 41 * The following macros are missing from some versions of winnt.h. 42 */ 43 44#ifndef PROCESSOR_ARCHITECTURE_INTEL 45#define PROCESSOR_ARCHITECTURE_INTEL 0 46#endif 47#ifndef PROCESSOR_ARCHITECTURE_MIPS 48#define PROCESSOR_ARCHITECTURE_MIPS 1 49#endif 50#ifndef PROCESSOR_ARCHITECTURE_ALPHA 51#define PROCESSOR_ARCHITECTURE_ALPHA 2 52#endif 53#ifndef PROCESSOR_ARCHITECTURE_PPC 54#define PROCESSOR_ARCHITECTURE_PPC 3 55#endif 56#ifndef PROCESSOR_ARCHITECTURE_SHX 57#define PROCESSOR_ARCHITECTURE_SHX 4 58#endif 59#ifndef PROCESSOR_ARCHITECTURE_ARM 60#define PROCESSOR_ARCHITECTURE_ARM 5 61#endif 62#ifndef PROCESSOR_ARCHITECTURE_IA64 63#define PROCESSOR_ARCHITECTURE_IA64 6 64#endif 65#ifndef PROCESSOR_ARCHITECTURE_ALPHA64 66#define PROCESSOR_ARCHITECTURE_ALPHA64 7 67#endif 68#ifndef PROCESSOR_ARCHITECTURE_MSIL 69#define PROCESSOR_ARCHITECTURE_MSIL 8 70#endif 71#ifndef PROCESSOR_ARCHITECTURE_AMD64 72#define PROCESSOR_ARCHITECTURE_AMD64 9 73#endif 74#ifndef PROCESSOR_ARCHITECTURE_IA32_ON_WIN64 75#define PROCESSOR_ARCHITECTURE_IA32_ON_WIN64 10 76#endif 77#ifndef PROCESSOR_ARCHITECTURE_UNKNOWN 78#define PROCESSOR_ARCHITECTURE_UNKNOWN 0xFFFF 79#endif 80 81/* 82 * The following arrays contain the human readable strings for the Windows 83 * platform and processor values. 84 */ 85 86 87#define NUMPLATFORMS 4 88static char* platforms[NUMPLATFORMS] = { 89 "Win32s", "Windows 95", "Windows NT", "Windows CE" 90}; 91 92#define NUMPROCESSORS 11 93static char* processors[NUMPROCESSORS] = { 94 "intel", "mips", "alpha", "ppc", "shx", "arm", "ia64", "alpha64", "msil", 95 "amd64", "ia32_on_win64" 96}; 97 98/* 99 * The default directory in which the init.tcl file is expected to be found. 100 */ 101 102static TclInitProcessGlobalValueProc InitializeDefaultLibraryDir; 103static ProcessGlobalValue defaultLibraryDir = 104 {0, 0, NULL, NULL, InitializeDefaultLibraryDir, NULL, NULL}; 105 106static void AppendEnvironment(Tcl_Obj *listPtr, CONST char *lib); 107static int ToUtf(CONST WCHAR *wSrc, char *dst); 108 109/* 110 *--------------------------------------------------------------------------- 111 * 112 * TclpInitPlatform -- 113 * 114 * Initialize all the platform-dependant things like signals and 115 * floating-point error handling. 116 * 117 * Called at process initialization time. 118 * 119 * Results: 120 * None. 121 * 122 * Side effects: 123 * None. 124 * 125 *--------------------------------------------------------------------------- 126 */ 127 128void 129TclpInitPlatform(void) 130{ 131 tclPlatform = TCL_PLATFORM_WINDOWS; 132 133 /* 134 * The following code stops Windows 3.X and Windows NT 3.51 from 135 * automatically putting up Sharing Violation dialogs, e.g, when someone 136 * tries to access a file that is locked or a drive with no disk in it. 137 * Tcl already returns the appropriate error to the caller, and they can 138 * decide to put up their own dialog in response to that failure. 139 * 140 * Under 95 and NT 4.0, this is a NOOP because the system doesn't 141 * automatically put up dialogs when the above operations fail. 142 */ 143 144 SetErrorMode(SetErrorMode(0) | SEM_FAILCRITICALERRORS); 145 146#ifdef STATIC_BUILD 147 /* 148 * If we are in a statically linked executable, then we need to explicitly 149 * initialize the Windows function tables here since DllMain() will not be 150 * invoked. 151 */ 152 153 TclWinInit(GetModuleHandle(NULL)); 154#endif 155} 156 157/* 158 *------------------------------------------------------------------------- 159 * 160 * TclpInitLibraryPath -- 161 * 162 * This is the fallback routine that sets the library path if the 163 * application has not set one by the first time it is needed. 164 * 165 * Results: 166 * None. 167 * 168 * Side effects: 169 * Sets the library path to an initial value. 170 * 171 *------------------------------------------------------------------------- 172 */ 173 174void 175TclpInitLibraryPath( 176 char **valuePtr, 177 int *lengthPtr, 178 Tcl_Encoding *encodingPtr) 179{ 180#define LIBRARY_SIZE 32 181 Tcl_Obj *pathPtr; 182 char installLib[LIBRARY_SIZE]; 183 char *bytes; 184 185 pathPtr = Tcl_NewObj(); 186 187 /* 188 * Initialize the substring used when locating the script library. The 189 * installLib variable computes the script library path relative to the 190 * installed DLL. 191 */ 192 193 sprintf(installLib, "lib/tcl%s", TCL_VERSION); 194 195 /* 196 * Look for the library relative to the TCL_LIBRARY env variable. If the 197 * last dirname in the TCL_LIBRARY path does not match the last dirname in 198 * the installLib variable, use the last dir name of installLib in 199 * addition to the orginal TCL_LIBRARY path. 200 */ 201 202 AppendEnvironment(pathPtr, installLib); 203 204 /* 205 * Look for the library in its default location. 206 */ 207 208 Tcl_ListObjAppendElement(NULL, pathPtr, 209 TclGetProcessGlobalValue(&defaultLibraryDir)); 210 211 *encodingPtr = NULL; 212 bytes = Tcl_GetStringFromObj(pathPtr, lengthPtr); 213 *valuePtr = ckalloc((unsigned int)(*lengthPtr)+1); 214 memcpy(*valuePtr, bytes, (size_t)(*lengthPtr)+1); 215 Tcl_DecrRefCount(pathPtr); 216} 217 218/* 219 *--------------------------------------------------------------------------- 220 * 221 * AppendEnvironment -- 222 * 223 * Append the value of the TCL_LIBRARY environment variable onto the path 224 * pointer. If the env variable points to another version of tcl (e.g. 225 * "tcl7.6") also append the path to this version (e.g., 226 * "tcl7.6/../tcl8.2") 227 * 228 * Results: 229 * None. 230 * 231 * Side effects: 232 * None. 233 * 234 *--------------------------------------------------------------------------- 235 */ 236 237static void 238AppendEnvironment( 239 Tcl_Obj *pathPtr, 240 CONST char *lib) 241{ 242 int pathc; 243 WCHAR wBuf[MAX_PATH]; 244 char buf[MAX_PATH * TCL_UTF_MAX]; 245 Tcl_Obj *objPtr; 246 Tcl_DString ds; 247 CONST char **pathv; 248 char *shortlib; 249 250 /* 251 * The shortlib value needs to be the tail component of the lib path. For 252 * example, "lib/tcl8.4" -> "tcl8.4" while "usr/share/tcl8.5" -> "tcl8.5". 253 */ 254 255 for (shortlib = (char *) &lib[strlen(lib)-1]; shortlib>lib ; shortlib--) { 256 if (*shortlib == '/') { 257 if ((unsigned)(shortlib - lib) == strlen(lib) - 1) { 258 Tcl_Panic("last character in lib cannot be '/'"); 259 } 260 shortlib++; 261 break; 262 } 263 } 264 if (shortlib == lib) { 265 Tcl_Panic("no '/' character found in lib"); 266 } 267 268 /* 269 * The "L" preceeding the TCL_LIBRARY string is used to tell VC++ that 270 * this is a unicode string. 271 */ 272 273 if (GetEnvironmentVariableW(L"TCL_LIBRARY", wBuf, MAX_PATH) == 0) { 274 buf[0] = '\0'; 275 GetEnvironmentVariableA("TCL_LIBRARY", buf, MAX_PATH); 276 } else { 277 ToUtf(wBuf, buf); 278 } 279 280 if (buf[0] != '\0') { 281 objPtr = Tcl_NewStringObj(buf, -1); 282 Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); 283 284 TclWinNoBackslash(buf); 285 Tcl_SplitPath(buf, &pathc, &pathv); 286 287 /* 288 * The lstrcmpi() will work even if pathv[pathc-1] is random UTF-8 289 * chars because I know shortlib is ascii. 290 */ 291 292 if ((pathc > 0) && (lstrcmpiA(shortlib, pathv[pathc - 1]) != 0)) { 293 CONST char *str; 294 295 /* 296 * TCL_LIBRARY is set but refers to a different tcl installation 297 * than the current version. Try fiddling with the specified 298 * directory to make it refer to this installation by removing the 299 * old "tclX.Y" and substituting the current version string. 300 */ 301 302 pathv[pathc - 1] = shortlib; 303 Tcl_DStringInit(&ds); 304 str = Tcl_JoinPath(pathc, pathv, &ds); 305 objPtr = Tcl_NewStringObj(str, Tcl_DStringLength(&ds)); 306 Tcl_DStringFree(&ds); 307 } else { 308 objPtr = Tcl_NewStringObj(buf, -1); 309 } 310 Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); 311 ckfree((char *) pathv); 312 } 313} 314 315/* 316 *--------------------------------------------------------------------------- 317 * 318 * InitializeDefaultLibraryDir -- 319 * 320 * Locate the Tcl script library default location relative to the 321 * location of the Tcl DLL. 322 * 323 * Results: 324 * None. 325 * 326 * Side effects: 327 * None. 328 * 329 *--------------------------------------------------------------------------- 330 */ 331 332static void 333InitializeDefaultLibraryDir( 334 char **valuePtr, 335 int *lengthPtr, 336 Tcl_Encoding *encodingPtr) 337{ 338 HMODULE hModule = TclWinGetTclInstance(); 339 WCHAR wName[MAX_PATH + LIBRARY_SIZE]; 340 char name[(MAX_PATH + LIBRARY_SIZE) * TCL_UTF_MAX]; 341 char *end, *p; 342 343 if (GetModuleFileNameW(hModule, wName, MAX_PATH) == 0) { 344 GetModuleFileNameA(hModule, name, MAX_PATH); 345 } else { 346 ToUtf(wName, name); 347 } 348 349 end = strrchr(name, '\\'); 350 *end = '\0'; 351 p = strrchr(name, '\\'); 352 if (p != NULL) { 353 end = p; 354 } 355 *end = '\\'; 356 357 TclWinNoBackslash(name); 358 sprintf(end + 1, "lib/tcl%s", TCL_VERSION); 359 *lengthPtr = strlen(name); 360 *valuePtr = ckalloc((unsigned int) *lengthPtr + 1); 361 *encodingPtr = NULL; 362 memcpy(*valuePtr, name, (size_t) *lengthPtr + 1); 363} 364 365/* 366 *--------------------------------------------------------------------------- 367 * 368 * ToUtf -- 369 * 370 * Convert a char string to a UTF string. 371 * 372 * Results: 373 * None. 374 * 375 * Side effects: 376 * None. 377 * 378 *--------------------------------------------------------------------------- 379 */ 380 381static int 382ToUtf( 383 CONST WCHAR *wSrc, 384 char *dst) 385{ 386 char *start; 387 388 start = dst; 389 while (*wSrc != '\0') { 390 dst += Tcl_UniCharToUtf(*wSrc, dst); 391 wSrc++; 392 } 393 *dst = '\0'; 394 return (int) (dst - start); 395} 396 397/* 398 *--------------------------------------------------------------------------- 399 * 400 * TclWinEncodingsCleanup -- 401 * 402 * Reset information to its original state in finalization to allow for 403 * reinitialization to be possible. This must not be called until after 404 * the filesystem has been finalised, or exit crashes may occur when 405 * using virtual filesystems. 406 * 407 * Results: 408 * None. 409 * 410 * Side effects: 411 * Static information reset to startup state. 412 * 413 *--------------------------------------------------------------------------- 414 */ 415 416void 417TclWinEncodingsCleanup(void) 418{ 419 TclWinResetInterfaceEncodings(); 420} 421 422/* 423 *--------------------------------------------------------------------------- 424 * 425 * TclpSetInitialEncodings -- 426 * 427 * Based on the locale, determine the encoding of the operating system 428 * and the default encoding for newly opened files. 429 * 430 * Called at process initialization time, and part way through startup, 431 * we verify that the initial encodings were correctly setup. Depending 432 * on Tcl's environment, there may not have been enough information first 433 * time through (above). 434 * 435 * Results: 436 * None. 437 * 438 * Side effects: 439 * The Tcl library path is converted from native encoding to UTF-8, on 440 * the first call, and the encodings may be changed on first or second 441 * call. 442 * 443 *--------------------------------------------------------------------------- 444 */ 445 446void 447TclpSetInitialEncodings(void) 448{ 449 Tcl_DString encodingName; 450 451 TclpSetInterfaces(); 452 Tcl_SetSystemEncoding(NULL, 453 Tcl_GetEncodingNameFromEnvironment(&encodingName)); 454 Tcl_DStringFree(&encodingName); 455} 456 457void 458TclpSetInterfaces(void) 459{ 460 int platformId, useWide; 461 462 platformId = TclWinGetPlatformId(); 463 useWide = ((platformId == VER_PLATFORM_WIN32_NT) 464 || (platformId == VER_PLATFORM_WIN32_CE)); 465 TclWinSetInterfaces(useWide); 466} 467 468CONST char * 469Tcl_GetEncodingNameFromEnvironment( 470 Tcl_DString *bufPtr) 471{ 472 Tcl_DStringInit(bufPtr); 473 Tcl_DStringSetLength(bufPtr, 2+TCL_INTEGER_SPACE); 474 wsprintfA(Tcl_DStringValue(bufPtr), "cp%d", GetACP()); 475 Tcl_DStringSetLength(bufPtr, strlen(Tcl_DStringValue(bufPtr))); 476 return Tcl_DStringValue(bufPtr); 477} 478 479/* 480 *--------------------------------------------------------------------------- 481 * 482 * TclpSetVariables -- 483 * 484 * Performs platform-specific interpreter initialization related to the 485 * tcl_platform and env variables, and other platform-specific things. 486 * 487 * Results: 488 * None. 489 * 490 * Side effects: 491 * Sets "tcl_platform", and "env(HOME)" Tcl variables. 492 * 493 *---------------------------------------------------------------------- 494 */ 495 496void 497TclpSetVariables( 498 Tcl_Interp *interp) /* Interp to initialize. */ 499{ 500 CONST char *ptr; 501 char buffer[TCL_INTEGER_SPACE * 2]; 502 SYSTEM_INFO sysInfo, *sysInfoPtr = &sysInfo; 503 OemId *oemId; 504 OSVERSIONINFOA osInfo; 505 Tcl_DString ds; 506 WCHAR szUserName[UNLEN+1]; 507 DWORD cchUserNameLen = UNLEN; 508 509 Tcl_SetVar2Ex(interp, "tclDefaultLibrary", NULL, 510 TclGetProcessGlobalValue(&defaultLibraryDir), TCL_GLOBAL_ONLY); 511 512 osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA); 513 GetVersionExA(&osInfo); 514 515 oemId = (OemId *) sysInfoPtr; 516 GetSystemInfo(&sysInfo); 517 518 /* 519 * Define the tcl_platform array. 520 */ 521 522 Tcl_SetVar2(interp, "tcl_platform", "platform", "windows", 523 TCL_GLOBAL_ONLY); 524 if (osInfo.dwPlatformId < NUMPLATFORMS) { 525 Tcl_SetVar2(interp, "tcl_platform", "os", 526 platforms[osInfo.dwPlatformId], TCL_GLOBAL_ONLY); 527 } 528 wsprintfA(buffer, "%d.%d", osInfo.dwMajorVersion, osInfo.dwMinorVersion); 529 Tcl_SetVar2(interp, "tcl_platform", "osVersion", buffer, TCL_GLOBAL_ONLY); 530 if (oemId->wProcessorArchitecture < NUMPROCESSORS) { 531 Tcl_SetVar2(interp, "tcl_platform", "machine", 532 processors[oemId->wProcessorArchitecture], 533 TCL_GLOBAL_ONLY); 534 } 535 536#ifdef _DEBUG 537 /* 538 * The existence of the "debug" element of the tcl_platform array 539 * indicates that this particular Tcl shell has been compiled with debug 540 * information. Using "info exists tcl_platform(debug)" a Tcl script can 541 * direct the interpreter to load debug versions of DLLs with the load 542 * command. 543 */ 544 545 Tcl_SetVar2(interp, "tcl_platform", "debug", "1", 546 TCL_GLOBAL_ONLY); 547#endif 548 549 /* 550 * Set up the HOME environment variable from the HOMEDRIVE & HOMEPATH 551 * environment variables, if necessary. 552 */ 553 554 Tcl_DStringInit(&ds); 555 ptr = Tcl_GetVar2(interp, "env", "HOME", TCL_GLOBAL_ONLY); 556 if (ptr == NULL) { 557 ptr = Tcl_GetVar2(interp, "env", "HOMEDRIVE", TCL_GLOBAL_ONLY); 558 if (ptr != NULL) { 559 Tcl_DStringAppend(&ds, ptr, -1); 560 } 561 ptr = Tcl_GetVar2(interp, "env", "HOMEPATH", TCL_GLOBAL_ONLY); 562 if (ptr != NULL) { 563 Tcl_DStringAppend(&ds, ptr, -1); 564 } 565 if (Tcl_DStringLength(&ds) > 0) { 566 Tcl_SetVar2(interp, "env", "HOME", Tcl_DStringValue(&ds), 567 TCL_GLOBAL_ONLY); 568 } else { 569 Tcl_SetVar2(interp, "env", "HOME", "c:\\", TCL_GLOBAL_ONLY); 570 } 571 } 572 573 /* 574 * Initialize the user name from the environment first, since this is much 575 * faster than asking the system. 576 * Note: cchUserNameLen is number of characters including nul terminator. 577 */ 578 579 Tcl_DStringInit(&ds); 580 if (TclGetEnv("USERNAME", &ds) == NULL) { 581 if (tclWinProcs->getUserName((LPTSTR)szUserName, &cchUserNameLen) != 0) { 582 int cbUserNameLen = cchUserNameLen - 1; 583 if (tclWinProcs->useWide) cbUserNameLen *= sizeof(WCHAR); 584 Tcl_WinTCharToUtf((LPTSTR)szUserName, cbUserNameLen, &ds); 585 } 586 } 587 Tcl_SetVar2(interp, "tcl_platform", "user", Tcl_DStringValue(&ds), 588 TCL_GLOBAL_ONLY); 589 Tcl_DStringFree(&ds); 590} 591 592/* 593 *---------------------------------------------------------------------- 594 * 595 * TclpFindVariable -- 596 * 597 * Locate the entry in environ for a given name. On Unix this routine is 598 * case sensitive, on Windows this matches mioxed case. 599 * 600 * Results: 601 * The return value is the index in environ of an entry with the name 602 * "name", or -1 if there is no such entry. The integer at *lengthPtr is 603 * filled in with the length of name (if a matching entry is found) or 604 * the length of the environ array (if no matching entry is found). 605 * 606 * Side effects: 607 * None. 608 * 609 *---------------------------------------------------------------------- 610 */ 611 612int 613TclpFindVariable( 614 CONST char *name, /* Name of desired environment variable 615 * (UTF-8). */ 616 int *lengthPtr) /* Used to return length of name (for 617 * successful searches) or number of non-NULL 618 * entries in environ (for unsuccessful 619 * searches). */ 620{ 621 int i, length, result = -1; 622 register CONST char *env, *p1, *p2; 623 char *envUpper, *nameUpper; 624 Tcl_DString envString; 625 626 /* 627 * Convert the name to all upper case for the case insensitive comparison. 628 */ 629 630 length = strlen(name); 631 nameUpper = (char *) ckalloc((unsigned) length+1); 632 memcpy(nameUpper, name, (size_t) length+1); 633 Tcl_UtfToUpper(nameUpper); 634 635 Tcl_DStringInit(&envString); 636 for (i = 0, env = environ[i]; env != NULL; i++, env = environ[i]) { 637 /* 638 * Chop the env string off after the equal sign, then Convert the name 639 * to all upper case, so we do not have to convert all the characters 640 * after the equal sign. 641 */ 642 643 envUpper = Tcl_ExternalToUtfDString(NULL, env, -1, &envString); 644 p1 = strchr(envUpper, '='); 645 if (p1 == NULL) { 646 continue; 647 } 648 length = (int) (p1 - envUpper); 649 Tcl_DStringSetLength(&envString, length+1); 650 Tcl_UtfToUpper(envUpper); 651 652 p1 = envUpper; 653 p2 = nameUpper; 654 for (; *p2 == *p1; p1++, p2++) { 655 /* NULL loop body. */ 656 } 657 if ((*p1 == '=') && (*p2 == '\0')) { 658 *lengthPtr = length; 659 result = i; 660 goto done; 661 } 662 663 Tcl_DStringFree(&envString); 664 } 665 666 *lengthPtr = i; 667 668 done: 669 Tcl_DStringFree(&envString); 670 ckfree(nameUpper); 671 return result; 672} 673 674/* 675 * Local Variables: 676 * mode: c 677 * c-basic-offset: 4 678 * fill-column: 78 679 * End: 680 */ 681