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