开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > Windows编程 > 通讯编程 > 查看源码
tclWinInit.c
资源名称：ns-allinone-2.33.tar.gz　[点击查看]
上传用户：rrhhcc
上传日期：2015-12-11
资源大小：54129k
文件大小：24k
源码类别：

通讯编程

开发平台：

Visual C++

tclWinInit.c：源码内容
  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.  */
  13. #include "tclWinInt.h"
  14. #include <winnt.h>
  15. #include <winbase.h>
  16. #include <lmcons.h>
  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.  */
  25. typedef struct {
  26.     WORD wProcessorArchitecture;
  27.     WORD wReserved;
  28. } OemId;
  30. /*
  31.  * The following macros are missing from some versions of winnt.h.
  32.  */
  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
  71. /*
  72.  * The following arrays contain the human readable strings for the Windows
  73.  * platform and processor values.
  74.  */
  77. #define NUMPLATFORMS 4
  78. static char* platforms[NUMPLATFORMS] = {
  79.     "Win32s", "Windows 95", "Windows NT", "Windows CE"
  80. };
  82. #define NUMPROCESSORS 11
  83. static char* processors[NUMPROCESSORS] = {
  84.     "intel", "mips", "alpha", "ppc", "shx", "arm", "ia64", "alpha64", "msil",
  85.     "amd64", "ia32_on_win64"
  86. };
  88. /* Used to store the encoding used for binary files */
  89. static Tcl_Encoding binaryEncoding = NULL;
  90. /* Has the basic library path encoding issue been fixed */
  91. static int libraryPathEncodingFixed = 0;
  93. /*
  94.  * The Init script (common to Windows and Unix platforms) is
  95.  * defined in tkInitScript.h
  96.  */
  98. #include "tclInitScript.h"
  100. static void AppendEnvironment(Tcl_Obj *listPtr, CONST char *lib);
  101. static void AppendDllPath(Tcl_Obj *listPtr, HMODULE hModule,
  102.     CONST char *lib);
  103. static int ToUtf(CONST WCHAR *wSrc, char *dst);
  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.  */
  124. void
  125. TclpInitPlatform()
  126. {
  127.     tclPlatform = TCL_PLATFORM_WINDOWS;
  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.      */
  141.     SetErrorMode(SetErrorMode(0) | SEM_FAILCRITICALERRORS);
  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.      */
  150.     TclWinInit(GetModuleHandle(NULL));
  151. #endif
  152. }
  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.  */
  176. int
  177. TclpInitLibraryPath(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];
  189.     Tcl_DStringInit(&ds);
  190.     pathPtr = Tcl_NewObj();
  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.      */
  199.     sprintf(installLib, "lib/tcl%s", TCL_VERSION);
  200.     sprintf(developLib, "tcl%s/library", TCL_PATCH_LEVEL);
  202.     /*
  203.      * Look for the library relative to default encoding dir.
  204.      */
  206.     str = Tcl_GetDefaultEncodingDir();
  207.     if ((str != NULL) && (str[0] != '')) {
  208. objPtr = Tcl_NewStringObj(str, -1);
  209. Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
  210.     }
  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.      */
  219.     AppendEnvironment(pathPtr, installLib);
  221.     /*
  222.      * Look for the library relative to the DLL.  Only use the installLib
  223.      * because in practice, the DLL is always installed.
  224.      */
  226.     AppendDllPath(pathPtr, TclWinGetTclInstance(), installLib);
  227.     
  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.      */
  254.     if (path != NULL) {
  255. int i, origc;
  256. CONST char **origv;
  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.     }
  332.     TclSetLibraryPath(pathPtr);
  334.     return 0; /* 0 indicates that pathPtr is clean (true) utf */
  335. }
  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.  */
  356. static void
  357. AppendEnvironment(
  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;
  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.     }
  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] = '';
  394. GetEnvironmentVariableA("TCL_LIBRARY", buf, MAX_PATH);
  395.     } else {
  396. ToUtf(wBuf, buf);
  397.     }
  399.     if (buf[0] != '') {
  400. objPtr = Tcl_NewStringObj(buf, -1);
  401. Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
  403. TclWinNoBackslash(buf);
  404. Tcl_SplitPath(buf, &pathc, &pathv);
  406. /* 
  407.  * The lstrcmpi() will work even if pathv[pathc - 1] is random
  408.  * UTF-8 chars because I know shortlib is ascii.
  409.  */
  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. }
  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.  */
  451. static void 
  452. AppendDllPath(
  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];
  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;
  468. end = strrchr(name, '\');
  469. *end = '';
  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. }
  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.  */
  497. static int
  498. ToUtf(
  499.     CONST WCHAR *wSrc,
  500.     char *dst)
  501. {
  502.     char *start;
  504.     start = dst;
  505.     while (*wSrc != '') {
  506. dst += Tcl_UniCharToUtf(*wSrc, dst);
  507. wSrc++;
  508.     }
  509.     *dst = '';
  510.     return (int) (dst - start);
  511. }
  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.  */
  532. void
  533. TclWinEncodingsCleanup()
  534. {
  535.     TclWinResetInterfaceEncodings();
  536.     libraryPathEncodingFixed = 0;
  537.     if (binaryEncoding != NULL) {
  538. Tcl_FreeEncoding(binaryEncoding);
  539. binaryEncoding = NULL;
  540.     }
  541. }
  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.  */
  567. void
  568. TclpSetInitialEncodings()
  569. {
  570.     CONST char *encoding;
  571.     char buf[4 + TCL_INTEGER_SPACE];
  573.     if (libraryPathEncodingFixed == 0) {
  574. int platformId, useWide;
  576. platformId = TclWinGetPlatformId();
  577. useWide = ((platformId == VER_PLATFORM_WIN32_NT)
  578. || (platformId == VER_PLATFORM_WIN32_CE));
  579. TclWinSetInterfaces(useWide);
  581. wsprintfA(buf, "cp%d", GetACP());
  582. Tcl_SetSystemEncoding(NULL, buf);
  584. if (!useWide) {
  585.     Tcl_Obj *pathPtr = TclGetLibraryPath();
  586.     if (pathPtr != NULL) {
  587. int i, objc;
  588. Tcl_Obj **objv;
  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;
  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. }
  606. libraryPathEncodingFixed = 1;
  607.     } else {
  608. wsprintfA(buf, "cp%d", GetACP());
  609. Tcl_SetSystemEncoding(NULL, buf);
  610.     }
  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. }
  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.  */
  641. void
  642. TclpSetVariables(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);
  654.     osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
  655.     GetVersionExA(&osInfo);
  657.     oemId = (OemId *) &sysInfo;
  658.     GetSystemInfo(&sysInfo);
  660.     /*
  661.      * Define the tcl_platform array.
  662.      */
  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.     }
  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.      */
  686.     Tcl_SetVar2(interp, "tcl_platform", "debug", "1",
  687.     TCL_GLOBAL_ONLY);
  688. #endif
  690.     /*
  691.      * Set up the HOME environment variable from the HOMEDRIVE & HOMEPATH
  692.      * environment variables, if necessary.
  693.      */
  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.     }
  714.     /*
  715.      * Initialize the user name from the environment first, since this is much
  716.      * faster than asking the system.
  717.      */
  719.     Tcl_DStringInit( &ds );
  720.     if (TclGetEnv("USERNAME", &ds) == NULL) {
  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. }
  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.  */
  752. int
  753. TclpFindVariable(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;
  766.     /*
  767.      * Convert the name to all upper case for the case insensitive
  768.      * comparison.
  769.      */
  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.  */
  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);
  793. p1 = envUpper;
  794. p2 = nameUpper;
  795. for (; *p2 == *p1; p1++, p2++) {
  796.     /* NULL loop body. */
  797. }
  798. if ((*p1 == '=') && (*p2 == '')) {
  799.     *lengthPtr = length;
  800.     result = i;
  801.     goto done;
  802. }
  804. Tcl_DStringFree(&envString);
  805.     }
  806.     
  807.     *lengthPtr = i;
  809.     done:
  810.     Tcl_DStringFree(&envString);
  811.     ckfree(nameUpper);
  812.     return result;
  813. }
  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.  */
  834. int
  835. Tcl_Init(interp)
  836.     Tcl_Interp *interp; /* Interpreter to initialize. */
  837. {
  838.     Tcl_Obj *pathPtr;
  840.     if (tclPreInitScript != NULL) {
  841. if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) {
  842.     return (TCL_ERROR);
  843. };
  844.     }
  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. }
  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.  */
  874. void
  875. Tcl_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;
  882.     fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY);
  884.     if (fileName != NULL) {
  885.         Tcl_Channel c;
  886. CONST char *fullName;
  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 {
  898.     /*
  899.      * Test for the existence of the rc file before trying to read it.
  900.      */
  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. }