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.2.1 2009/07/01 14:05:19 patthoyts 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
35typedef 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
88static char* platforms[NUMPLATFORMS] = {
89    "Win32s", "Windows 95", "Windows NT", "Windows CE"
90};
91
92#define NUMPROCESSORS 11
93static 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
102static TclInitProcessGlobalValueProc	InitializeDefaultLibraryDir;
103static ProcessGlobalValue defaultLibraryDir =
104	{0, 0, NULL, NULL, InitializeDefaultLibraryDir, NULL, NULL};
105
106static void		AppendEnvironment(Tcl_Obj *listPtr, CONST char *lib);
107static 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
128void
129TclpInitPlatform(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
174void
175TclpInitLibraryPath(
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
237static void
238AppendEnvironment(
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
332static void
333InitializeDefaultLibraryDir(
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
381static int
382ToUtf(
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
416void
417TclWinEncodingsCleanup(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
446void
447TclpSetInitialEncodings(void)
448{
449    Tcl_DString encodingName;
450
451    TclpSetInterfaces();
452    Tcl_SetSystemEncoding(NULL,
453	    Tcl_GetEncodingNameFromEnvironment(&encodingName));
454    Tcl_DStringFree(&encodingName);
455}
456
457void
458TclpSetInterfaces(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
468CONST char *
469Tcl_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
496void
497TclpSetVariables(
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    WCHAR szUserName[UNLEN+1];
507    DWORD cchUserNameLen = UNLEN;
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     * Note: cchUserNameLen is number of characters including nul terminator.
577     */
578
579    Tcl_DStringInit(&ds);
580    if (TclGetEnv("USERNAME", &ds) == NULL) {
581	if (tclWinProcs->getUserName((LPTSTR)szUserName, &cchUserNameLen) != 0) {
582	    int cbUserNameLen = cchUserNameLen - 1;
583	    if (tclWinProcs->useWide) cbUserNameLen *= sizeof(WCHAR);
584	    Tcl_WinTCharToUtf((LPTSTR)szUserName, cbUserNameLen, &ds);
585	}
586    }
587    Tcl_SetVar2(interp, "tcl_platform", "user", Tcl_DStringValue(&ds),
588	    TCL_GLOBAL_ONLY);
589    Tcl_DStringFree(&ds);
590}
591
592/*
593 *----------------------------------------------------------------------
594 *
595 * TclpFindVariable --
596 *
597 *	Locate the entry in environ for a given name. On Unix this routine is
598 *	case sensitive, on Windows this matches mioxed case.
599 *
600 * Results:
601 *	The return value is the index in environ of an entry with the name
602 *	"name", or -1 if there is no such entry. The integer at *lengthPtr is
603 *	filled in with the length of name (if a matching entry is found) or
604 *	the length of the environ array (if no matching entry is found).
605 *
606 * Side effects:
607 *	None.
608 *
609 *----------------------------------------------------------------------
610 */
611
612int
613TclpFindVariable(
614    CONST char *name,		/* Name of desired environment variable
615				 * (UTF-8). */
616    int *lengthPtr)		/* Used to return length of name (for
617				 * successful searches) or number of non-NULL
618				 * entries in environ (for unsuccessful
619				 * searches). */
620{
621    int i, length, result = -1;
622    register CONST char *env, *p1, *p2;
623    char *envUpper, *nameUpper;
624    Tcl_DString envString;
625
626    /*
627     * Convert the name to all upper case for the case insensitive comparison.
628     */
629
630    length = strlen(name);
631    nameUpper = (char *) ckalloc((unsigned) length+1);
632    memcpy(nameUpper, name, (size_t) length+1);
633    Tcl_UtfToUpper(nameUpper);
634
635    Tcl_DStringInit(&envString);
636    for (i = 0, env = environ[i]; env != NULL; i++, env = environ[i]) {
637	/*
638	 * Chop the env string off after the equal sign, then Convert the name
639	 * to all upper case, so we do not have to convert all the characters
640	 * after the equal sign.
641	 */
642
643	envUpper = Tcl_ExternalToUtfDString(NULL, env, -1, &envString);
644	p1 = strchr(envUpper, '=');
645	if (p1 == NULL) {
646	    continue;
647	}
648	length = (int) (p1 - envUpper);
649	Tcl_DStringSetLength(&envString, length+1);
650	Tcl_UtfToUpper(envUpper);
651
652	p1 = envUpper;
653	p2 = nameUpper;
654	for (; *p2 == *p1; p1++, p2++) {
655	    /* NULL loop body. */
656	}
657	if ((*p1 == '=') && (*p2 == '\0')) {
658	    *lengthPtr = length;
659	    result = i;
660	    goto done;
661	}
662
663	Tcl_DStringFree(&envString);
664    }
665
666    *lengthPtr = i;
667
668  done:
669    Tcl_DStringFree(&envString);
670    ckfree(nameUpper);
671    return result;
672}
673
674/*
675 * Local Variables:
676 * mode: c
677 * c-basic-offset: 4
678 * fill-column: 78
679 * End:
680 */
681