/[dtapublic]/to_be_filed/sf_code/esrgpcpj/shared/tcl_base/tclwininit.c
ViewVC logotype

Annotation of /to_be_filed/sf_code/esrgpcpj/shared/tcl_base/tclwininit.c

Parent Directory Parent Directory | Revision Log Revision Log


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

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25