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