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 * RCS: @(#) $Id: tclWinInit.c,v 1.40.2.6 2005/10/23 22:01:31 msofer Exp $ 11 */ 12 13#include "tclWinInt.h" 14#include <winnt.h> 15#include <winbase.h> 16#include <lmcons.h> 17 18/* 19 * The following declaration is a workaround for some Microsoft brain damage. 20 * The SYSTEM_INFO structure is different in various releases, even though the 21 * layout is the same. So we overlay our own structure on top of it so we 22 * can access the interesting slots in a uniform way. 23 */ 24 25typedef struct { 26 WORD wProcessorArchitecture; 27 WORD wReserved; 28} OemId; 29 30/* 31 * The following macros are missing from some versions of winnt.h. 32 */ 33 34#ifndef PROCESSOR_ARCHITECTURE_INTEL 35#define PROCESSOR_ARCHITECTURE_INTEL 0 36#endif 37#ifndef PROCESSOR_ARCHITECTURE_MIPS 38#define PROCESSOR_ARCHITECTURE_MIPS 1 39#endif 40#ifndef PROCESSOR_ARCHITECTURE_ALPHA 41#define PROCESSOR_ARCHITECTURE_ALPHA 2 42#endif 43#ifndef PROCESSOR_ARCHITECTURE_PPC 44#define PROCESSOR_ARCHITECTURE_PPC 3 45#endif 46#ifndef PROCESSOR_ARCHITECTURE_SHX 47#define PROCESSOR_ARCHITECTURE_SHX 4 48#endif 49#ifndef PROCESSOR_ARCHITECTURE_ARM 50#define PROCESSOR_ARCHITECTURE_ARM 5 51#endif 52#ifndef PROCESSOR_ARCHITECTURE_IA64 53#define PROCESSOR_ARCHITECTURE_IA64 6 54#endif 55#ifndef PROCESSOR_ARCHITECTURE_ALPHA64 56#define PROCESSOR_ARCHITECTURE_ALPHA64 7 57#endif 58#ifndef PROCESSOR_ARCHITECTURE_MSIL 59#define PROCESSOR_ARCHITECTURE_MSIL 8 60#endif 61#ifndef PROCESSOR_ARCHITECTURE_AMD64 62#define PROCESSOR_ARCHITECTURE_AMD64 9 63#endif 64#ifndef PROCESSOR_ARCHITECTURE_IA32_ON_WIN64 65#define PROCESSOR_ARCHITECTURE_IA32_ON_WIN64 10 66#endif 67#ifndef PROCESSOR_ARCHITECTURE_UNKNOWN 68#define PROCESSOR_ARCHITECTURE_UNKNOWN 0xFFFF 69#endif 70 71/* 72 * The following arrays contain the human readable strings for the Windows 73 * platform and processor values. 74 */ 75 76 77#define NUMPLATFORMS 4 78static char* platforms[NUMPLATFORMS] = { 79 "Win32s", "Windows 95", "Windows NT", "Windows CE" 80}; 81 82#define NUMPROCESSORS 11 83static char* processors[NUMPROCESSORS] = { 84 "intel", "mips", "alpha", "ppc", "shx", "arm", "ia64", "alpha64", "msil", 85 "amd64", "ia32_on_win64" 86}; 87 88/* Used to store the encoding used for binary files */ 89static Tcl_Encoding binaryEncoding = NULL; 90/* Has the basic library path encoding issue been fixed */ 91static int libraryPathEncodingFixed = 0; 92 93/* 94 * The Init script (common to Windows and Unix platforms) is 95 * defined in tkInitScript.h 96 */ 97 98#include "tclInitScript.h" 99 100static void AppendEnvironment(Tcl_Obj *listPtr, CONST char *lib); 101static void AppendDllPath(Tcl_Obj *listPtr, HMODULE hModule, 102 CONST char *lib); 103static int ToUtf(CONST WCHAR *wSrc, char *dst); 104 105/* 106 *--------------------------------------------------------------------------- 107 * 108 * TclpInitPlatform -- 109 * 110 * Initialize all the platform-dependant things like signals and 111 * floating-point error handling. 112 * 113 * Called at process initialization time. 114 * 115 * Results: 116 * None. 117 * 118 * Side effects: 119 * None. 120 * 121 *--------------------------------------------------------------------------- 122 */ 123 124void 125TclpInitPlatform() 126{ 127 tclPlatform = TCL_PLATFORM_WINDOWS; 128 129 /* 130 * The following code stops Windows 3.X and Windows NT 3.51 from 131 * automatically putting up Sharing Violation dialogs, e.g, when 132 * someone tries to access a file that is locked or a drive with no 133 * disk in it. Tcl already returns the appropriate error to the 134 * caller, and they can decide to put up their own dialog in response 135 * to that failure. 136 * 137 * Under 95 and NT 4.0, this is a NOOP because the system doesn't 138 * automatically put up dialogs when the above operations fail. 139 */ 140 141 SetErrorMode(SetErrorMode(0) | SEM_FAILCRITICALERRORS); 142 143#ifdef STATIC_BUILD 144 /* 145 * If we are in a statically linked executable, then we need to 146 * explicitly initialize the Windows function tables here since 147 * DllMain() will not be invoked. 148 */ 149 150 TclWinInit(GetModuleHandle(NULL)); 151#endif 152} 153 154/* 155 *--------------------------------------------------------------------------- 156 * 157 * TclpInitLibraryPath -- 158 * 159 * Initialize the library path at startup. 160 * 161 * This call sets the library path to strings in UTF-8. Any 162 * pre-existing library path information is assumed to have been 163 * in the native multibyte encoding. 164 * 165 * Called at process initialization time. 166 * 167 * Results: 168 * Return 0, indicating that the UTF is clean. 169 * 170 * Side effects: 171 * None. 172 * 173 *--------------------------------------------------------------------------- 174 */ 175 176int 177TclpInitLibraryPath(path) 178 CONST char *path; /* Potentially dirty UTF string that is */ 179 /* the path to the executable name. */ 180{ 181#define LIBRARY_SIZE 32 182 Tcl_Obj *pathPtr, *objPtr; 183 CONST char *str; 184 Tcl_DString ds; 185 int pathc; 186 CONST char **pathv; 187 char installLib[LIBRARY_SIZE], developLib[LIBRARY_SIZE]; 188 189 Tcl_DStringInit(&ds); 190 pathPtr = Tcl_NewObj(); 191 192 /* 193 * Initialize the substrings used when locating an executable. The 194 * installLib variable computes the path as though the executable 195 * is installed. The developLib computes the path as though the 196 * executable is run from a develpment directory. 197 */ 198 199 sprintf(installLib, "lib/tcl%s", TCL_VERSION); 200 sprintf(developLib, "tcl%s/library", TCL_PATCH_LEVEL); 201 202 /* 203 * Look for the library relative to default encoding dir. 204 */ 205 206 str = Tcl_GetDefaultEncodingDir(); 207 if ((str != NULL) && (str[0] != '\0')) { 208 objPtr = Tcl_NewStringObj(str, -1); 209 Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); 210 } 211 212 /* 213 * Look for the library relative to the TCL_LIBRARY env variable. 214 * If the last dirname in the TCL_LIBRARY path does not match the 215 * last dirname in the installLib variable, use the last dir name 216 * of installLib in addition to the orginal TCL_LIBRARY path. 217 */ 218 219 AppendEnvironment(pathPtr, installLib); 220 221 /* 222 * Look for the library relative to the DLL. Only use the installLib 223 * because in practice, the DLL is always installed. 224 */ 225 226 AppendDllPath(pathPtr, TclWinGetTclInstance(), installLib); 227 228 229 /* 230 * Look for the library relative to the executable. This algorithm 231 * should be the same as the one in the tcl_findLibrary procedure. 232 * 233 * This code looks in the following directories: 234 * 235 * <bindir>/../<installLib> 236 * (e.g. /usr/local/bin/../lib/tcl8.4) 237 * <bindir>/../../<installLib> 238 * (e.g. /usr/local/TclPro/solaris-sparc/bin/../../lib/tcl8.4) 239 * <bindir>/../library 240 * (e.g. /usr/src/tcl8.4.0/unix/../library) 241 * <bindir>/../../library 242 * (e.g. /usr/src/tcl8.4.0/unix/solaris-sparc/../../library) 243 * <bindir>/../../<developLib> 244 * (e.g. /usr/src/tcl8.4.0/unix/../../tcl8.4.0/library) 245 * <bindir>/../../../<developLib> 246 * (e.g. /usr/src/tcl8.4.0/unix/solaris-sparc/../../../tcl8.4.0/library) 247 */ 248 249 /* 250 * The variable path holds an absolute path. Take care not to 251 * overwrite pathv[0] since that might produce a relative path. 252 */ 253 254 if (path != NULL) { 255 int i, origc; 256 CONST char **origv; 257 258 Tcl_SplitPath(path, &origc, &origv); 259 pathc = 0; 260 pathv = (CONST char **) ckalloc((unsigned int)(origc * sizeof(char *))); 261 for (i=0; i< origc; i++) { 262 if (origv[i][0] == '.') { 263 if (strcmp(origv[i], ".") == 0) { 264 /* do nothing */ 265 } else if (strcmp(origv[i], "..") == 0) { 266 pathc--; 267 } else { 268 pathv[pathc++] = origv[i]; 269 } 270 } else { 271 pathv[pathc++] = origv[i]; 272 } 273 } 274 if (pathc > 2) { 275 str = pathv[pathc - 2]; 276 pathv[pathc - 2] = installLib; 277 path = Tcl_JoinPath(pathc - 1, pathv, &ds); 278 pathv[pathc - 2] = str; 279 objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds)); 280 Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); 281 Tcl_DStringFree(&ds); 282 } 283 if (pathc > 3) { 284 str = pathv[pathc - 3]; 285 pathv[pathc - 3] = installLib; 286 path = Tcl_JoinPath(pathc - 2, pathv, &ds); 287 pathv[pathc - 3] = str; 288 objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds)); 289 Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); 290 Tcl_DStringFree(&ds); 291 } 292 if (pathc > 2) { 293 str = pathv[pathc - 2]; 294 pathv[pathc - 2] = "library"; 295 path = Tcl_JoinPath(pathc - 1, pathv, &ds); 296 pathv[pathc - 2] = str; 297 objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds)); 298 Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); 299 Tcl_DStringFree(&ds); 300 } 301 if (pathc > 3) { 302 str = pathv[pathc - 3]; 303 pathv[pathc - 3] = "library"; 304 path = Tcl_JoinPath(pathc - 2, pathv, &ds); 305 pathv[pathc - 3] = str; 306 objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds)); 307 Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); 308 Tcl_DStringFree(&ds); 309 } 310 if (pathc > 3) { 311 str = pathv[pathc - 3]; 312 pathv[pathc - 3] = developLib; 313 path = Tcl_JoinPath(pathc - 2, pathv, &ds); 314 pathv[pathc - 3] = str; 315 objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds)); 316 Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); 317 Tcl_DStringFree(&ds); 318 } 319 if (pathc > 4) { 320 str = pathv[pathc - 4]; 321 pathv[pathc - 4] = developLib; 322 path = Tcl_JoinPath(pathc - 3, pathv, &ds); 323 pathv[pathc - 4] = str; 324 objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds)); 325 Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); 326 Tcl_DStringFree(&ds); 327 } 328 ckfree((char *) origv); 329 ckfree((char *) pathv); 330 } 331 332 TclSetLibraryPath(pathPtr); 333 334 return 0; /* 0 indicates that pathPtr is clean (true) utf */ 335} 336 337/* 338 *--------------------------------------------------------------------------- 339 * 340 * AppendEnvironment -- 341 * 342 * Append the value of the TCL_LIBRARY environment variable onto the 343 * path pointer. If the env variable points to another version of 344 * tcl (e.g. "tcl7.6") also append the path to this version (e.g., 345 * "tcl7.6/../tcl8.2") 346 * 347 * Results: 348 * None. 349 * 350 * Side effects: 351 * None. 352 * 353 *--------------------------------------------------------------------------- 354 */ 355 356static void 357AppendEnvironment( 358 Tcl_Obj *pathPtr, 359 CONST char *lib) 360{ 361 int pathc; 362 WCHAR wBuf[MAX_PATH]; 363 char buf[MAX_PATH * TCL_UTF_MAX]; 364 Tcl_Obj *objPtr; 365 Tcl_DString ds; 366 CONST char **pathv; 367 char *shortlib; 368 369 /* 370 * The shortlib value needs to be the tail component of the 371 * lib path. For example, "lib/tcl8.4" -> "tcl8.4" while 372 * "usr/share/tcl8.5" -> "tcl8.5". 373 */ 374 for (shortlib = (char *) (lib + strlen(lib) - 1); shortlib > lib ; shortlib--) { 375 if (*shortlib == '/') { 376 if (shortlib == (lib + strlen(lib) - 1)) { 377 Tcl_Panic("last character in lib cannot be '/'"); 378 } 379 shortlib++; 380 break; 381 } 382 } 383 if (shortlib == lib) { 384 Tcl_Panic("no '/' character found in lib"); 385 } 386 387 /* 388 * The "L" preceeding the TCL_LIBRARY string is used to tell VC++ 389 * that this is a unicode string. 390 */ 391 392 if (GetEnvironmentVariableW(L"TCL_LIBRARY", wBuf, MAX_PATH) == 0) { 393 buf[0] = '\0'; 394 GetEnvironmentVariableA("TCL_LIBRARY", buf, MAX_PATH); 395 } else { 396 ToUtf(wBuf, buf); 397 } 398 399 if (buf[0] != '\0') { 400 objPtr = Tcl_NewStringObj(buf, -1); 401 Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); 402 403 TclWinNoBackslash(buf); 404 Tcl_SplitPath(buf, &pathc, &pathv); 405 406 /* 407 * The lstrcmpi() will work even if pathv[pathc - 1] is random 408 * UTF-8 chars because I know shortlib is ascii. 409 */ 410 411 if ((pathc > 0) && (lstrcmpiA(shortlib, pathv[pathc - 1]) != 0)) { 412 CONST char *str; 413 /* 414 * TCL_LIBRARY is set but refers to a different tcl 415 * installation than the current version. Try fiddling with the 416 * specified directory to make it refer to this installation by 417 * removing the old "tclX.Y" and substituting the current 418 * version string. 419 */ 420 421 pathv[pathc - 1] = shortlib; 422 Tcl_DStringInit(&ds); 423 str = Tcl_JoinPath(pathc, pathv, &ds); 424 objPtr = Tcl_NewStringObj(str, Tcl_DStringLength(&ds)); 425 Tcl_DStringFree(&ds); 426 } else { 427 objPtr = Tcl_NewStringObj(buf, -1); 428 } 429 Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); 430 ckfree((char *) pathv); 431 } 432} 433 434/* 435 *--------------------------------------------------------------------------- 436 * 437 * AppendDllPath -- 438 * 439 * Append a path onto the path pointer that tries to locate the Tcl 440 * library relative to the location of the Tcl DLL. 441 * 442 * Results: 443 * None. 444 * 445 * Side effects: 446 * None. 447 * 448 *--------------------------------------------------------------------------- 449 */ 450 451static void 452AppendDllPath( 453 Tcl_Obj *pathPtr, 454 HMODULE hModule, 455 CONST char *lib) 456{ 457 WCHAR wName[MAX_PATH + LIBRARY_SIZE]; 458 char name[(MAX_PATH + LIBRARY_SIZE) * TCL_UTF_MAX]; 459 460 if (GetModuleFileNameW(hModule, wName, MAX_PATH) == 0) { 461 GetModuleFileNameA(hModule, name, MAX_PATH); 462 } else { 463 ToUtf(wName, name); 464 } 465 if (lib != NULL) { 466 char *end, *p; 467 468 end = strrchr(name, '\\'); 469 *end = '\0'; 470 p = strrchr(name, '\\'); 471 if (p != NULL) { 472 end = p; 473 } 474 *end = '\\'; 475 strcpy(end + 1, lib); 476 } 477 TclWinNoBackslash(name); 478 Tcl_ListObjAppendElement(NULL, pathPtr, Tcl_NewStringObj(name, -1)); 479} 480 481/* 482 *--------------------------------------------------------------------------- 483 * 484 * ToUtf -- 485 * 486 * Convert a char string to a UTF string. 487 * 488 * Results: 489 * None. 490 * 491 * Side effects: 492 * None. 493 * 494 *--------------------------------------------------------------------------- 495 */ 496 497static int 498ToUtf( 499 CONST WCHAR *wSrc, 500 char *dst) 501{ 502 char *start; 503 504 start = dst; 505 while (*wSrc != '\0') { 506 dst += Tcl_UniCharToUtf(*wSrc, dst); 507 wSrc++; 508 } 509 *dst = '\0'; 510 return (int) (dst - start); 511} 512 513/* 514 *--------------------------------------------------------------------------- 515 * 516 * TclWinEncodingsCleanup -- 517 * 518 * Reset information to its original state in finalization to 519 * allow for reinitialization to be possible. This must not 520 * be called until after the filesystem has been finalised, or 521 * exit crashes may occur when using virtual filesystems. 522 * 523 * Results: 524 * None. 525 * 526 * Side effects: 527 * Static information reset to startup state. 528 * 529 *--------------------------------------------------------------------------- 530 */ 531 532void 533TclWinEncodingsCleanup() 534{ 535 TclWinResetInterfaceEncodings(); 536 libraryPathEncodingFixed = 0; 537 if (binaryEncoding != NULL) { 538 Tcl_FreeEncoding(binaryEncoding); 539 binaryEncoding = NULL; 540 } 541} 542 543/* 544 *--------------------------------------------------------------------------- 545 * 546 * TclpSetInitialEncodings -- 547 * 548 * Based on the locale, determine the encoding of the operating 549 * system and the default encoding for newly opened files. 550 * 551 * Called at process initialization time, and part way through 552 * startup, we verify that the initial encodings were correctly 553 * setup. Depending on Tcl's environment, there may not have been 554 * enough information first time through (above). 555 * 556 * Results: 557 * None. 558 * 559 * Side effects: 560 * The Tcl library path is converted from native encoding to UTF-8, 561 * on the first call, and the encodings may be changed on first or 562 * second call. 563 * 564 *--------------------------------------------------------------------------- 565 */ 566 567void 568TclpSetInitialEncodings() 569{ 570 CONST char *encoding; 571 char buf[4 + TCL_INTEGER_SPACE]; 572 573 if (libraryPathEncodingFixed == 0) { 574 int platformId, useWide; 575 576 platformId = TclWinGetPlatformId(); 577 useWide = ((platformId == VER_PLATFORM_WIN32_NT) 578 || (platformId == VER_PLATFORM_WIN32_CE)); 579 TclWinSetInterfaces(useWide); 580 581 wsprintfA(buf, "cp%d", GetACP()); 582 Tcl_SetSystemEncoding(NULL, buf); 583 584 if (!useWide) { 585 Tcl_Obj *pathPtr = TclGetLibraryPath(); 586 if (pathPtr != NULL) { 587 int i, objc; 588 Tcl_Obj **objv; 589 590 objc = 0; 591 Tcl_ListObjGetElements(NULL, pathPtr, &objc, &objv); 592 for (i = 0; i < objc; i++) { 593 int length; 594 char *string; 595 Tcl_DString ds; 596 597 string = Tcl_GetStringFromObj(objv[i], &length); 598 Tcl_ExternalToUtfDString(NULL, string, length, &ds); 599 Tcl_SetStringObj(objv[i], Tcl_DStringValue(&ds), 600 Tcl_DStringLength(&ds)); 601 Tcl_DStringFree(&ds); 602 } 603 } 604 } 605 606 libraryPathEncodingFixed = 1; 607 } else { 608 wsprintfA(buf, "cp%d", GetACP()); 609 Tcl_SetSystemEncoding(NULL, buf); 610 } 611 612 /* This is only ever called from the startup thread */ 613 if (binaryEncoding == NULL) { 614 /* 615 * Keep this encoding preloaded. The IO package uses it for 616 * gets on a binary channel. 617 */ 618 encoding = "iso8859-1"; 619 binaryEncoding = Tcl_GetEncoding(NULL, encoding); 620 } 621} 622 623/* 624 *--------------------------------------------------------------------------- 625 * 626 * TclpSetVariables -- 627 * 628 * Performs platform-specific interpreter initialization related to 629 * the tcl_platform and env variables, and other platform-specific 630 * things. 631 * 632 * Results: 633 * None. 634 * 635 * Side effects: 636 * Sets "tcl_platform", and "env(HOME)" Tcl variables. 637 * 638 *---------------------------------------------------------------------- 639 */ 640 641void 642TclpSetVariables(interp) 643 Tcl_Interp *interp; /* Interp to initialize. */ 644{ 645 CONST char *ptr; 646 char buffer[TCL_INTEGER_SPACE * 2]; 647 SYSTEM_INFO sysInfo; 648 OemId *oemId; 649 OSVERSIONINFOA osInfo; 650 Tcl_DString ds; 651 TCHAR szUserName[ UNLEN+1 ]; 652 DWORD dwUserNameLen = sizeof(szUserName); 653 654 osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA); 655 GetVersionExA(&osInfo); 656 657 oemId = (OemId *) &sysInfo; 658 GetSystemInfo(&sysInfo); 659 660 /* 661 * Define the tcl_platform array. 662 */ 663 664 Tcl_SetVar2(interp, "tcl_platform", "platform", "windows", 665 TCL_GLOBAL_ONLY); 666 if (osInfo.dwPlatformId < NUMPLATFORMS) { 667 Tcl_SetVar2(interp, "tcl_platform", "os", 668 platforms[osInfo.dwPlatformId], TCL_GLOBAL_ONLY); 669 } 670 wsprintfA(buffer, "%d.%d", osInfo.dwMajorVersion, osInfo.dwMinorVersion); 671 Tcl_SetVar2(interp, "tcl_platform", "osVersion", buffer, TCL_GLOBAL_ONLY); 672 if (oemId->wProcessorArchitecture < NUMPROCESSORS) { 673 Tcl_SetVar2(interp, "tcl_platform", "machine", 674 processors[oemId->wProcessorArchitecture], 675 TCL_GLOBAL_ONLY); 676 } 677 678#ifdef _DEBUG 679 /* 680 * The existence of the "debug" element of the tcl_platform array indicates 681 * that this particular Tcl shell has been compiled with debug information. 682 * Using "info exists tcl_platform(debug)" a Tcl script can direct the 683 * interpreter to load debug versions of DLLs with the load command. 684 */ 685 686 Tcl_SetVar2(interp, "tcl_platform", "debug", "1", 687 TCL_GLOBAL_ONLY); 688#endif 689 690 /* 691 * Set up the HOME environment variable from the HOMEDRIVE & HOMEPATH 692 * environment variables, if necessary. 693 */ 694 695 Tcl_DStringInit(&ds); 696 ptr = Tcl_GetVar2(interp, "env", "HOME", TCL_GLOBAL_ONLY); 697 if (ptr == NULL) { 698 ptr = Tcl_GetVar2(interp, "env", "HOMEDRIVE", TCL_GLOBAL_ONLY); 699 if (ptr != NULL) { 700 Tcl_DStringAppend(&ds, ptr, -1); 701 } 702 ptr = Tcl_GetVar2(interp, "env", "HOMEPATH", TCL_GLOBAL_ONLY); 703 if (ptr != NULL) { 704 Tcl_DStringAppend(&ds, ptr, -1); 705 } 706 if (Tcl_DStringLength(&ds) > 0) { 707 Tcl_SetVar2(interp, "env", "HOME", Tcl_DStringValue(&ds), 708 TCL_GLOBAL_ONLY); 709 } else { 710 Tcl_SetVar2(interp, "env", "HOME", "c:\\", TCL_GLOBAL_ONLY); 711 } 712 } 713 714 /* 715 * Initialize the user name from the environment first, since this is much 716 * faster than asking the system. 717 */ 718 719 Tcl_DStringInit( &ds ); 720 if (TclGetEnv("USERNAME", &ds) == NULL) { 721 722 if ( GetUserName( szUserName, &dwUserNameLen ) != 0 ) { 723 Tcl_WinTCharToUtf( szUserName, dwUserNameLen, &ds ); 724 } 725 } 726 Tcl_SetVar2(interp, "tcl_platform", "user", Tcl_DStringValue(&ds), 727 TCL_GLOBAL_ONLY); 728 Tcl_DStringFree(&ds); 729} 730 731/* 732 *---------------------------------------------------------------------- 733 * 734 * TclpFindVariable -- 735 * 736 * Locate the entry in environ for a given name. On Unix this 737 * routine is case sensetive, on Windows this matches mioxed case. 738 * 739 * Results: 740 * The return value is the index in environ of an entry with the 741 * name "name", or -1 if there is no such entry. The integer at 742 * *lengthPtr is filled in with the length of name (if a matching 743 * entry is found) or the length of the environ array (if no matching 744 * entry is found). 745 * 746 * Side effects: 747 * None. 748 * 749 *---------------------------------------------------------------------- 750 */ 751 752int 753TclpFindVariable(name, lengthPtr) 754 CONST char *name; /* Name of desired environment variable 755 * (UTF-8). */ 756 int *lengthPtr; /* Used to return length of name (for 757 * successful searches) or number of non-NULL 758 * entries in environ (for unsuccessful 759 * searches). */ 760{ 761 int i, length, result = -1; 762 register CONST char *env, *p1, *p2; 763 char *envUpper, *nameUpper; 764 Tcl_DString envString; 765 766 /* 767 * Convert the name to all upper case for the case insensitive 768 * comparison. 769 */ 770 771 length = strlen(name); 772 nameUpper = (char *) ckalloc((unsigned) length+1); 773 memcpy((VOID *) nameUpper, (VOID *) name, (size_t) length+1); 774 Tcl_UtfToUpper(nameUpper); 775 776 Tcl_DStringInit(&envString); 777 for (i = 0, env = environ[i]; env != NULL; i++, env = environ[i]) { 778 /* 779 * Chop the env string off after the equal sign, then Convert 780 * the name to all upper case, so we do not have to convert 781 * all the characters after the equal sign. 782 */ 783 784 envUpper = Tcl_ExternalToUtfDString(NULL, env, -1, &envString); 785 p1 = strchr(envUpper, '='); 786 if (p1 == NULL) { 787 continue; 788 } 789 length = (int) (p1 - envUpper); 790 Tcl_DStringSetLength(&envString, length+1); 791 Tcl_UtfToUpper(envUpper); 792 793 p1 = envUpper; 794 p2 = nameUpper; 795 for (; *p2 == *p1; p1++, p2++) { 796 /* NULL loop body. */ 797 } 798 if ((*p1 == '=') && (*p2 == '\0')) { 799 *lengthPtr = length; 800 result = i; 801 goto done; 802 } 803 804 Tcl_DStringFree(&envString); 805 } 806 807 *lengthPtr = i; 808 809 done: 810 Tcl_DStringFree(&envString); 811 ckfree(nameUpper); 812 return result; 813} 814 815/* 816 *---------------------------------------------------------------------- 817 * 818 * Tcl_Init -- 819 * 820 * This procedure is typically invoked by Tcl_AppInit procedures 821 * to perform additional initialization for a Tcl interpreter, 822 * such as sourcing the "init.tcl" script. 823 * 824 * Results: 825 * Returns a standard Tcl completion code and sets the interp's 826 * result if there is an error. 827 * 828 * Side effects: 829 * Depends on what's in the init.tcl script. 830 * 831 *---------------------------------------------------------------------- 832 */ 833 834int 835Tcl_Init(interp) 836 Tcl_Interp *interp; /* Interpreter to initialize. */ 837{ 838 Tcl_Obj *pathPtr; 839 840 if (tclPreInitScript != NULL) { 841 if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) { 842 return (TCL_ERROR); 843 }; 844 } 845 846 pathPtr = TclGetLibraryPath(); 847 if (pathPtr == NULL) { 848 pathPtr = Tcl_NewObj(); 849 } 850 Tcl_IncrRefCount(pathPtr); 851 Tcl_SetVar2Ex(interp, "tcl_libPath", NULL, pathPtr, TCL_GLOBAL_ONLY); 852 Tcl_DecrRefCount(pathPtr); 853 return Tcl_Eval(interp, initScript); 854} 855 856/* 857 *---------------------------------------------------------------------- 858 * 859 * Tcl_SourceRCFile -- 860 * 861 * This procedure is typically invoked by Tcl_Main of Tk_Main 862 * procedure to source an application specific rc file into the 863 * interpreter at startup time. 864 * 865 * Results: 866 * None. 867 * 868 * Side effects: 869 * Depends on what's in the rc script. 870 * 871 *---------------------------------------------------------------------- 872 */ 873 874void 875Tcl_SourceRCFile(interp) 876 Tcl_Interp *interp; /* Interpreter to source rc file into. */ 877{ 878 Tcl_DString temp; 879 CONST char *fileName; 880 Tcl_Channel errChannel; 881 882 fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY); 883 884 if (fileName != NULL) { 885 Tcl_Channel c; 886 CONST char *fullName; 887 888 Tcl_DStringInit(&temp); 889 fullName = Tcl_TranslateFileName(interp, fileName, &temp); 890 if (fullName == NULL) { 891 /* 892 * Couldn't translate the file name (e.g. it referred to a 893 * bogus user or there was no HOME environment variable). 894 * Just do nothing. 895 */ 896 } else { 897 898 /* 899 * Test for the existence of the rc file before trying to read it. 900 */ 901 902 c = Tcl_OpenFileChannel(NULL, fullName, "r", 0); 903 if (c != (Tcl_Channel) NULL) { 904 Tcl_Close(NULL, c); 905 if (Tcl_EvalFile(interp, fullName) != TCL_OK) { 906 errChannel = Tcl_GetStdChannel(TCL_STDERR); 907 if (errChannel) { 908 Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); 909 Tcl_WriteChars(errChannel, "\n", 1); 910 } 911 } 912 } 913 } 914 Tcl_DStringFree(&temp); 915 } 916} 917