356 lines
9.2 KiB
C
356 lines
9.2 KiB
C
|
/*
|
|||
|
|
* tclWinInit.c --
|
|||
|
|
*
|
|||
|
|
* Contains the Windows-specific interpreter initialization functions.
|
|||
|
|
*
|
|||
|
|
* Copyright (c) 1994-1996 Sun Microsystems, Inc.
|
|||
|
|
*
|
|||
|
|
* See the file "license.terms" for information on usage and redistribution
|
|||
|
|
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
|||
|
|
*
|
|||
|
|
* SCCS: @(#) tclWinInit.c 1.23 96/10/04 17:05:02
|
|||
|
|
*/
|
|||
|
|
|
|||
|
|
#include "tclInt.h"
|
|||
|
|
#include "tclPort.h"
|
|||
|
|
#include <winreg.h>
|
|||
|
|
#include <winnt.h>
|
|||
|
|
#include <winbase.h>
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* The following declaration is a workaround for some Microsoft brain damage.
|
|||
|
|
* The SYSTEM_INFO structure is different in various releases, even though the
|
|||
|
|
* layout is the same. So we overlay our own structure on top of it so we
|
|||
|
|
* can access the interesting slots in a uniform way.
|
|||
|
|
*/
|
|||
|
|
|
|||
|
|
typedef struct {
|
|||
|
|
WORD wProcessorArchitecture;
|
|||
|
|
WORD wReserved;
|
|||
|
|
} OemId;
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* The following macros are missing from some versions of winnt.h.
|
|||
|
|
*/
|
|||
|
|
|
|||
|
|
#ifndef PROCESSOR_ARCHITECTURE_INTEL
|
|||
|
|
#define PROCESSOR_ARCHITECTURE_INTEL 0
|
|||
|
|
#endif
|
|||
|
|
#ifndef PROCESSOR_ARCHITECTURE_MIPS
|
|||
|
|
#define PROCESSOR_ARCHITECTURE_MIPS 1
|
|||
|
|
#endif
|
|||
|
|
#ifndef PROCESSOR_ARCHITECTURE_ALPHA
|
|||
|
|
#define PROCESSOR_ARCHITECTURE_ALPHA 2
|
|||
|
|
#endif
|
|||
|
|
#ifndef PROCESSOR_ARCHITECTURE_PPC
|
|||
|
|
#define PROCESSOR_ARCHITECTURE_PPC 3
|
|||
|
|
#endif
|
|||
|
|
#ifndef PROCESSOR_ARCHITECTURE_UNKNOWN
|
|||
|
|
#define PROCESSOR_ARCHITECTURE_UNKNOWN 0xFFFF
|
|||
|
|
#endif
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* The following arrays contain the human readable strings for the Windows
|
|||
|
|
* platform and processor values.
|
|||
|
|
*/
|
|||
|
|
|
|||
|
|
|
|||
|
|
#define NUMPLATFORMS 3
|
|||
|
|
static char* platforms[NUMPLATFORMS] = {
|
|||
|
|
"Win32s", "Windows 95", "Windows NT"
|
|||
|
|
};
|
|||
|
|
|
|||
|
|
#define NUMPROCESSORS 4
|
|||
|
|
static char* processors[NUMPROCESSORS] = {
|
|||
|
|
"intel", "mips", "alpha", "ppc"
|
|||
|
|
};
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* The following string is the startup script executed in new
|
|||
|
|
* interpreters. It looks on disk in several different directories
|
|||
|
|
* for a script "init.tcl" that is compatible with this version
|
|||
|
|
* of Tcl. The init.tcl script does all of the real work of
|
|||
|
|
* initialization.
|
|||
|
|
*/
|
|||
|
|
|
|||
|
|
static char *initScript =
|
|||
|
|
"proc init {} {\n\
|
|||
|
|
global tcl_library tcl_version tcl_patchLevel env\n\
|
|||
|
|
rename init {}\n\
|
|||
|
|
set dirs {}\n\
|
|||
|
|
if [info exists env(TCL_LIBRARY)] {\n\
|
|||
|
|
lappend dirs $env(TCL_LIBRARY)\n\
|
|||
|
|
}\n\
|
|||
|
|
lappend dirs $tcl_library\n\
|
|||
|
|
lappend dirs [file join [file dirname [file dirname [info nameofexecutable]]] lib/tcl$tcl_version]\n\
|
|||
|
|
if [string match {*[ab]*} $tcl_patchLevel] {\n\
|
|||
|
|
set lib tcl$tcl_patchLevel\n\
|
|||
|
|
} else {\n\
|
|||
|
|
set lib tcl$tcl_version\n\
|
|||
|
|
}\n\
|
|||
|
|
lappend dirs [file join [file dirname [file dirname [pwd]]] $lib/library]\n\
|
|||
|
|
lappend dirs [file join [file dirname [pwd]] library]\n\
|
|||
|
|
foreach i $dirs {\n\
|
|||
|
|
set tcl_library $i\n\
|
|||
|
|
if ![catch {uplevel #0 source [list [file join $i init.tcl]]}] {\n\
|
|||
|
|
return\n\
|
|||
|
|
}\n\
|
|||
|
|
}\n\
|
|||
|
|
set msg \"Can't find a usable init.tcl in the following directories: \n\"\n\
|
|||
|
|
append msg \" $dirs\n\"\n\
|
|||
|
|
append msg \"This probably means that Tcl wasn't installed properly.\n\"\n\
|
|||
|
|
error $msg\n\
|
|||
|
|
}\n\
|
|||
|
|
init";
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
*----------------------------------------------------------------------
|
|||
|
|
*
|
|||
|
|
* TclPlatformInit --
|
|||
|
|
*
|
|||
|
|
* Performs Windows-specific interpreter initialization related to the
|
|||
|
|
* tcl_library variable. Also sets up the HOME environment variable
|
|||
|
|
* if it is not already set.
|
|||
|
|
*
|
|||
|
|
* Results:
|
|||
|
|
* None.
|
|||
|
|
*
|
|||
|
|
* Side effects:
|
|||
|
|
* Sets "tcl_library" and "env(HOME)" Tcl variables
|
|||
|
|
*
|
|||
|
|
*----------------------------------------------------------------------
|
|||
|
|
*/
|
|||
|
|
|
|||
|
|
void
|
|||
|
|
TclPlatformInit(interp)
|
|||
|
|
Tcl_Interp *interp;
|
|||
|
|
{
|
|||
|
|
char *ptr;
|
|||
|
|
char buffer[13];
|
|||
|
|
Tcl_DString ds;
|
|||
|
|
OSVERSIONINFO osInfo;
|
|||
|
|
SYSTEM_INFO sysInfo;
|
|||
|
|
int isWin32s; /* True if we are running under Win32s. */
|
|||
|
|
OemId *oemId;
|
|||
|
|
HKEY key;
|
|||
|
|
DWORD size;
|
|||
|
|
|
|||
|
|
tclPlatform = TCL_PLATFORM_WINDOWS;
|
|||
|
|
|
|||
|
|
Tcl_DStringInit(&ds);
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* Find out what kind of system we are running on.
|
|||
|
|
*/
|
|||
|
|
|
|||
|
|
osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
|
|||
|
|
GetVersionEx(&osInfo);
|
|||
|
|
|
|||
|
|
isWin32s = (osInfo.dwPlatformId == VER_PLATFORM_WIN32s);
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* Since Win32s doesn't support GetSystemInfo, we use a default value.
|
|||
|
|
*/
|
|||
|
|
|
|||
|
|
oemId = (OemId *) &sysInfo;
|
|||
|
|
if (!isWin32s) {
|
|||
|
|
GetSystemInfo(&sysInfo);
|
|||
|
|
} else {
|
|||
|
|
oemId->wProcessorArchitecture = PROCESSOR_ARCHITECTURE_INTEL;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* Initialize the tcl_library variable from the registry.
|
|||
|
|
*/
|
|||
|
|
|
|||
|
|
if (!isWin32s) {
|
|||
|
|
if ((RegOpenKeyEx(HKEY_LOCAL_MACHINE,
|
|||
|
|
"Software\\Sun\\Tcl\\" TCL_VERSION, 0, KEY_READ, &key)
|
|||
|
|
== ERROR_SUCCESS)
|
|||
|
|
&& (RegQueryValueEx(key, "Root", NULL, NULL, NULL, &size)
|
|||
|
|
== ERROR_SUCCESS)) {
|
|||
|
|
Tcl_DStringSetLength(&ds, size);
|
|||
|
|
RegQueryValueEx(key, "Root", NULL, NULL, Tcl_DStringValue(&ds),
|
|||
|
|
&size);
|
|||
|
|
}
|
|||
|
|
} else {
|
|||
|
|
if ((RegOpenKeyEx(HKEY_CLASSES_ROOT,
|
|||
|
|
"Software\\Sun\\Tcl\\" TCL_VERSION, 0, KEY_READ, &key)
|
|||
|
|
== ERROR_SUCCESS)
|
|||
|
|
&& (RegQueryValueEx(key, "", NULL, NULL, NULL, &size)
|
|||
|
|
== ERROR_SUCCESS)) {
|
|||
|
|
Tcl_DStringSetLength(&ds, size);
|
|||
|
|
RegQueryValueEx(key, "", NULL, NULL, Tcl_DStringValue(&ds), &size);
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
Tcl_SetVar(interp, "tcl_library", Tcl_DStringValue(&ds), TCL_GLOBAL_ONLY);
|
|||
|
|
if (Tcl_DStringLength(&ds) > 0) {
|
|||
|
|
char *argv[3];
|
|||
|
|
argv[0] = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
|
|||
|
|
argv[1] = "lib";
|
|||
|
|
argv[2] = NULL;
|
|||
|
|
Tcl_DStringSetLength(&ds, 0);
|
|||
|
|
Tcl_SetVar(interp, "tcl_pkgPath", Tcl_JoinPath(2, argv, &ds),
|
|||
|
|
TCL_GLOBAL_ONLY);
|
|||
|
|
argv[1] = "lib/tcl" TCL_VERSION;
|
|||
|
|
Tcl_DStringSetLength(&ds, 0);
|
|||
|
|
Tcl_SetVar(interp, "tcl_library", Tcl_JoinPath(2, argv, &ds),
|
|||
|
|
TCL_GLOBAL_ONLY);
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* Define the tcl_platform array.
|
|||
|
|
*/
|
|||
|
|
|
|||
|
|
Tcl_SetVar2(interp, "tcl_platform", "platform", "windows",
|
|||
|
|
TCL_GLOBAL_ONLY);
|
|||
|
|
if (osInfo.dwPlatformId < NUMPLATFORMS) {
|
|||
|
|
Tcl_SetVar2(interp, "tcl_platform", "os",
|
|||
|
|
platforms[osInfo.dwPlatformId], TCL_GLOBAL_ONLY);
|
|||
|
|
}
|
|||
|
|
sprintf(buffer, "%d.%d", osInfo.dwMajorVersion, osInfo.dwMinorVersion);
|
|||
|
|
Tcl_SetVar2(interp, "tcl_platform", "osVersion", buffer, TCL_GLOBAL_ONLY);
|
|||
|
|
if (oemId->wProcessorArchitecture < NUMPROCESSORS) {
|
|||
|
|
Tcl_SetVar2(interp, "tcl_platform", "machine",
|
|||
|
|
processors[oemId->wProcessorArchitecture],
|
|||
|
|
TCL_GLOBAL_ONLY);
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* Set up the HOME environment variable from the HOMEDRIVE & HOMEPATH
|
|||
|
|
* environment variables, if necessary.
|
|||
|
|
*/
|
|||
|
|
|
|||
|
|
ptr = Tcl_GetVar2(interp, "env", "HOME", TCL_GLOBAL_ONLY);
|
|||
|
|
if (ptr == NULL) {
|
|||
|
|
Tcl_DStringSetLength(&ds, 0);
|
|||
|
|
ptr = Tcl_GetVar2(interp, "env", "HOMEDRIVE", TCL_GLOBAL_ONLY);
|
|||
|
|
if (ptr != NULL) {
|
|||
|
|
Tcl_DStringAppend(&ds, ptr, -1);
|
|||
|
|
}
|
|||
|
|
ptr = Tcl_GetVar2(interp, "env", "HOMEPATH", TCL_GLOBAL_ONLY);
|
|||
|
|
if (ptr != NULL) {
|
|||
|
|
Tcl_DStringAppend(&ds, ptr, -1);
|
|||
|
|
}
|
|||
|
|
if (Tcl_DStringLength(&ds) > 0) {
|
|||
|
|
Tcl_SetVar2(interp, "env", "HOME", Tcl_DStringValue(&ds),
|
|||
|
|
TCL_GLOBAL_ONLY);
|
|||
|
|
} else {
|
|||
|
|
Tcl_SetVar2(interp, "env", "HOME", "c:\\", TCL_GLOBAL_ONLY);
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
Tcl_DStringFree(&ds);
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
*----------------------------------------------------------------------
|
|||
|
|
*
|
|||
|
|
* Tcl_Init --
|
|||
|
|
*
|
|||
|
|
* This procedure is typically invoked by Tcl_AppInit procedures
|
|||
|
|
* to perform additional initialization for a Tcl interpreter,
|
|||
|
|
* such as sourcing the "init.tcl" script.
|
|||
|
|
*
|
|||
|
|
* Results:
|
|||
|
|
* Returns a standard Tcl completion code and sets interp->result
|
|||
|
|
* if there is an error.
|
|||
|
|
*
|
|||
|
|
* Side effects:
|
|||
|
|
* Depends on what's in the init.tcl script.
|
|||
|
|
*
|
|||
|
|
*----------------------------------------------------------------------
|
|||
|
|
*/
|
|||
|
|
|
|||
|
|
int
|
|||
|
|
Tcl_Init(interp)
|
|||
|
|
Tcl_Interp *interp; /* Interpreter to initialize. */
|
|||
|
|
{
|
|||
|
|
return Tcl_Eval(interp, initScript);
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
*----------------------------------------------------------------------
|
|||
|
|
*
|
|||
|
|
* TclWinGetPlatform --
|
|||
|
|
*
|
|||
|
|
* This is a kludge that allows the test library to get access
|
|||
|
|
* the internal tclPlatform variable.
|
|||
|
|
*
|
|||
|
|
* Results:
|
|||
|
|
* Returns a pointer to the tclPlatform variable.
|
|||
|
|
*
|
|||
|
|
* Side effects:
|
|||
|
|
* None.
|
|||
|
|
*
|
|||
|
|
*----------------------------------------------------------------------
|
|||
|
|
*/
|
|||
|
|
|
|||
|
|
TclPlatformType *
|
|||
|
|
TclWinGetPlatform()
|
|||
|
|
{
|
|||
|
|
return &tclPlatform;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
*----------------------------------------------------------------------
|
|||
|
|
*
|
|||
|
|
* Tcl_SourceRCFile --
|
|||
|
|
*
|
|||
|
|
* This procedure is typically invoked by Tcl_Main of Tk_Main
|
|||
|
|
* procedure to source an application specific rc file into the
|
|||
|
|
* interpreter at startup time.
|
|||
|
|
*
|
|||
|
|
* Results:
|
|||
|
|
* None.
|
|||
|
|
*
|
|||
|
|
* Side effects:
|
|||
|
|
* Depends on what's in the rc script.
|
|||
|
|
*
|
|||
|
|
*----------------------------------------------------------------------
|
|||
|
|
*/
|
|||
|
|
|
|||
|
|
void
|
|||
|
|
Tcl_SourceRCFile(interp)
|
|||
|
|
Tcl_Interp *interp; /* Interpreter to source rc file into. */
|
|||
|
|
{
|
|||
|
|
Tcl_DString temp;
|
|||
|
|
char *fileName;
|
|||
|
|
Tcl_Channel errChannel;
|
|||
|
|
|
|||
|
|
fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY);
|
|||
|
|
|
|||
|
|
if (fileName != NULL) {
|
|||
|
|
Tcl_Channel c;
|
|||
|
|
char *fullName;
|
|||
|
|
|
|||
|
|
Tcl_DStringInit(&temp);
|
|||
|
|
fullName = Tcl_TranslateFileName(interp, fileName, &temp);
|
|||
|
|
if (fullName == NULL) {
|
|||
|
|
errChannel = Tcl_GetStdChannel(TCL_STDERR);
|
|||
|
|
if (errChannel) {
|
|||
|
|
Tcl_Write(errChannel, interp->result, -1);
|
|||
|
|
Tcl_Write(errChannel, "\n", 1);
|
|||
|
|
}
|
|||
|
|
} else {
|
|||
|
|
|
|||
|
|
/*
|
|||
|
|
* Test for the existence of the rc file before trying to read it.
|
|||
|
|
*/
|
|||
|
|
|
|||
|
|
c = Tcl_OpenFileChannel(NULL, fullName, "r", 0);
|
|||
|
|
if (c != (Tcl_Channel) NULL) {
|
|||
|
|
Tcl_Close(NULL, c);
|
|||
|
|
if (Tcl_EvalFile(interp, fullName) != TCL_OK) {
|
|||
|
|
errChannel = Tcl_GetStdChannel(TCL_STDERR);
|
|||
|
|
if (errChannel) {
|
|||
|
|
Tcl_Write(errChannel, interp->result, -1);
|
|||
|
|
Tcl_Write(errChannel, "\n", 1);
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
Tcl_DStringFree(&temp);
|
|||
|
|
}
|
|||
|
|
}
|