home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
OS/2 Shareware BBS: 10 Tools
/
10-Tools.zip
/
tcltk805.zip
/
tcl805s.zip
/
tcl8.0.5
/
os2
/
tclOS2Init.c
< prev
next >
Wrap
C/C++ Source or Header
|
2001-02-09
|
16KB
|
613 lines
/*
* tclOS2Init.c --
*
* Contains the OS/2-specific interpreter initialization functions.
*
* Copyright (c) 1994-1996 Sun Microsystems, Inc.
* Copyright (c) 1996-2001 Illya Vaes
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclOS2Int.h"
/*
* The following macro can be defined at compile time to specify
* the Tcl profile key.
*/
#ifndef TCL_REGISTRY_KEY
/*
#define TCL_REGISTRY_KEY "Software\\Scriptics\\Tcl\\" TCL_VERSION
*/
#define TCL_REGISTRY_KEY "Tcl" TCL_PATCH_LEVEL
#endif
/* How many file handles do we want? OS/2 default is 20 */
#define MAX_FH ((ULONG) 25)
/* Global PM variables, necessary because of event loop and thus console */
HAB tclHab= (HAB)0;
HMQ tclHmq= (HMQ)0;
/* Other global variables */
ULONG maxPath;
LONG rc;
BOOL usePm = TRUE;
ULONG sysInfo[QSV_MAX]; /* System Information Data Buffer */
#ifdef VERBOSE
int openedFiles = 0; /* Files opened by us with DosOpen/DosDupHandle */
#endif
/*
* The following variable remembers if we've already initialized PM.
*/
static BOOL initialized = FALSE;
/*
* The following arrays contain the human readable strings for the OS/2
* version values.
*/
static char* processors[] = { "intel", "ppc" };
static const int numProcessors = sizeof(processors);
#ifndef PROCESSOR_ARCHITECTURE_INTEL
#define PROCESSOR_ARCHITECTURE_INTEL 0
#endif
#ifndef PROCESSOR_ARCHITECTURE_PPC
#define PROCESSOR_ARCHITECTURE_PPC 1
#endif
#ifndef PROCESSOR_ARCHITECTURE_UNKNOWN
#define PROCESSOR_ARCHITECTURE_UNKNOWN 0xFFFF
#endif
/*
* The Init script, tclPreInitScript variable, and the routine
* TclSetPreInitScript (common to Windows, OS/2 and Unix platforms) are
* defined in generic/tclInitScript.h
*/
#include "tclInitScript.h"
/*
*----------------------------------------------------------------------
*
* TclPlatformInit --
*
* Performs OS/2-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 *p;
/* buffer is Used for both PrfQueryProfileString and DosQuerySysInfo */
char buffer[CCHMAXPATH];
char *args[3];
char **argv;
int argc;
Tcl_DString ds;
int cpu = PROCESSOR_ARCHITECTURE_INTEL;
#ifdef VERBOSE
printf("TclPlatformInit, interp = 0x%x\n", interp);
#endif
tclPlatform = TCL_PLATFORM_OS2;
if (interp == (Tcl_Interp *)NULL) {
return;
}
Tcl_DStringInit(&ds);
/*
* Initialize the tcl_library variable from the user profile (OS2.INI).
* Environment overrides if set.
*/
Tcl_SetVar(interp, "tclDefaultLibrary", "", TCL_GLOBAL_ONLY);
#ifdef VERBOSE
printf("After Tcl_SetVar tclDefaultLibrary \"\"\n");
#endif
rc = PrfQueryProfileString(HINI_PROFILE, TCL_REGISTRY_KEY, "InstallDir",
NULL, &buffer, CCHMAXPATH);
#ifdef VERBOSE
printf("PrfQueryProfileString InstallDir returns %d [%s]\n", rc, buffer);
#endif
if (rc >= 0 && rc < CCHMAXPATH) {
buffer[rc] = '\0';
}
Tcl_SetVar(interp, "tclDefaultLibrary", buffer, TCL_GLOBAL_ONLY);
#ifdef VERBOSE
printf("After Tcl_SetVar tclDefaultLibrary \"%s\"\n", buffer);
#endif
args[0] = Tcl_GetVar(interp, "tclDefaultLibrary", TCL_GLOBAL_ONLY);
args[1] = "lib/tcl" TCL_VERSION;
args[2] = NULL;
Tcl_DStringSetLength(&ds, 0);
Tcl_SetVar(interp, "tclDefaultLibrary", Tcl_JoinPath(2, args, &ds),
TCL_GLOBAL_ONLY);
#ifdef VERBOSE
printf("tclDefaultLibrary [%s] (%d)\n",
Tcl_GetVar(interp, "tclDefaultLibrary", TCL_GLOBAL_ONLY), rc);
#endif
/*
* PkgPath is stored as an array of null terminated strings
* terminated by two null characters. First count the number
* of strings, then allocate an argv array so we can construct
* a valid list.
*/
memset((void *)buffer, 0, CCHMAXPATH);
rc = PrfQueryProfileString(HINI_PROFILE, TCL_REGISTRY_KEY, "PkgPath",
NULL, &buffer, CCHMAXPATH);
#ifdef VERBOSE
printf("PkgPath INI-file [%s] (%d)\n", buffer, rc);
#endif
argc = 0;
p = buffer;
do {
if (*p) {
argc++;
}
p += strlen(p) + 1;
} while (*p);
argv = (char **) ckalloc((sizeof(char *) * argc) + 1);
argc = 0;
p = buffer;
do {
if (*p) {
argv[argc++] = p;
while (*p) {
if (*p == '\\') {
*p = '/';
}
p++;
}
}
p++;
} while (*p);
p = Tcl_Merge(argc, argv);
Tcl_SetVar(interp, "tcl_pkgPath", p, TCL_GLOBAL_ONLY);
#ifdef VERBOSE
printf("tcl_pkgPath [%s]\n",
Tcl_GetVar(interp, "tcl_pkgPath", TCL_GLOBAL_ONLY));
#endif
Tcl_Free(p);
ckfree((char*) argv);
/* Request all available system information */
rc= DosQuerySysInfo (1L, QSV_MAX, (PVOID)sysInfo, sizeof(ULONG)*QSV_MAX);
maxPath = sysInfo[QSV_MAX_PATH_LENGTH - 1];
#ifdef VERBOSE
printf("major version [%d], minor version [%d], rev. [%d], maxPath [%d]\n",
sysInfo[QSV_VERSION_MAJOR - 1], sysInfo[QSV_VERSION_MINOR - 1],
sysInfo[QSV_VERSION_REVISION - 1], sysInfo[QSV_MAX_PATH_LENGTH - 1]);
#endif
/*
* Define the tcl_platform array.
*/
Tcl_SetVar2(interp, "tcl_platform", "platform", "os2", TCL_GLOBAL_ONLY);
Tcl_SetVar2(interp, "tcl_platform", "os", "OS/2", TCL_GLOBAL_ONLY);
/*
* Hack for LX-versions above 2.11
* OS/2 version MAJOR MINOR
* 2.0 20 0
* 2.1 20 10
* 2.11 20 11
* 3.0 20 30
* 4.0 20 40
*/
if (sysInfo[QSV_VERSION_MAJOR-1]==20 && sysInfo[QSV_VERSION_MINOR-1] > 11) {
int major = (int) (sysInfo[QSV_VERSION_MINOR - 1] / 10);
sprintf(buffer, "%d.%d", major,
(int) sysInfo[QSV_VERSION_MINOR - 1] - major * 10);
} else {
sprintf(buffer, "%d.%d", (int) (sysInfo[QSV_VERSION_MAJOR - 1] / 10),
(int)sysInfo[QSV_VERSION_MINOR - 1]);
}
Tcl_SetVar2(interp, "tcl_platform", "osVersion", buffer, TCL_GLOBAL_ONLY);
/* No API for determining processor (yet) */
Tcl_SetVar2(interp, "tcl_platform", "machine", processors[cpu],
TCL_GLOBAL_ONLY);
/*
* Set up the HOME environment variable from the HOMEDRIVE & HOMEPATH
* environment variables, if necessary.
*/
p = Tcl_GetVar2(interp, "env", "HOME", TCL_GLOBAL_ONLY);
if (p == NULL) {
Tcl_DStringSetLength(&ds, 0);
p = Tcl_GetVar2(interp, "env", "HOMEDRIVE", TCL_GLOBAL_ONLY);
if (p != NULL) {
Tcl_DStringAppend(&ds, p, -1);
}
p = Tcl_GetVar2(interp, "env", "HOMEPATH", TCL_GLOBAL_ONLY);
if (p != NULL) {
Tcl_DStringAppend(&ds, p, -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. */
{
if (tclPreInitScript != NULL) {
if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) {
return (TCL_ERROR);
};
}
return(Tcl_Eval(interp, initScript));
}
/*
*----------------------------------------------------------------------
*
* TclOS2GetPlatform --
*
* 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 *
TclOS2GetPlatform()
{
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;
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) {
/*
* Couldn't translate the file name (e.g. it referred to a
* bogus user or there was no HOME environment variable).
* Just do nothing.
*/
} 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) {
#ifndef CLI_VERSION
char cbuf[1000];
sprintf(cbuf, "%s\n", Tcl_GetStringResult(interp));
WinMessageBox(HWND_DESKTOP, NULLHANDLE, cbuf, "Tclsh", 0,
MB_OK | MB_ICONEXCLAMATION | MB_APPLMODAL);
#else
errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errChannel) {
Tcl_Write(errChannel, interp->result, -1);
Tcl_Write(errChannel, "\n", 1);
}
#endif
}
}
}
Tcl_DStringFree(&temp);
}
}
/*
*----------------------------------------------------------------------
*
* TclOS2PMInitialize --
*
* Performs OS/2-specific initialization. When we are not going to
* use PM perse (command line version), we only determine the anchor
* block handle, which is necessary if/when the registry package is
* loaded.
*
* Results:
* True or false depending on intialization.
*
* Side effects:
* Opens the "PM connection"
*
*----------------------------------------------------------------------
*/
BOOL
TclOS2PMInitialize(void)
{
if (initialized) return TRUE;
initialized = TRUE;
if (TclOS2GetUsePm()) {
/* Initialize PM */
tclHab = WinInitialize (0);
#ifdef VERBOSE
printf("HAB: %x\n", tclHab);
#endif
if (tclHab == NULLHANDLE) return FALSE;
/* Create message queue, increased size from 10 */
tclHmq= WinCreateMsgQueue (tclHab, 64);
if (tclHmq == NULLHANDLE) {
WinTerminate(tclHab);
tclHab= (HAB)0;
return FALSE;
}
}
return TRUE;
}
/*
*----------------------------------------------------------------------
*
* TclOS2PMShutdown --
*
* Performs OS/2-specific cleanup.
*
* Results:
* None.
*
* Side effects:
* Closes the "PM connection"
*
*----------------------------------------------------------------------
*/
void
TclOS2PMShutdown(void)
{
BOOL rc;
if (TclOS2GetUsePm()) {
/* Reset pointer to arrow */
rc = WinSetPointer(HWND_DESKTOP,
WinQuerySysPointer(HWND_DESKTOP, SPTR_ARROW, FALSE));
#ifdef VERBOSE
if (rc != TRUE) {
printf("WinSetPointer TclOS2PMShutdown ERROR: %x\n",
WinGetLastError(tclHab));
} else {
printf("WinSetPointer TclOS2PMShutdown OK\n");
}
#endif
WinDestroyMsgQueue(tclHmq);
tclHmq= (HMQ)0;
WinTerminate(tclHab);
tclHab= (HAB)0;
}
initialized = FALSE;
}
/*
*----------------------------------------------------------------------
*
* TclOS2GetHAB --
*
* Get the handle to the anchor block.
*
* Results:
* HAB or NULLHANDLE.
*
* Side effects:
* None
*
*----------------------------------------------------------------------
*/
HAB
TclOS2GetHAB(void)
{
#ifdef VERBOSE
printf("TclOS2GetHAB returning %x\n", tclHab);
#endif
return tclHab;
}
/*
*----------------------------------------------------------------------
*
* TclOS2GetHMQ --
*
* Get the handle to the message queue.
*
* Results:
* HMQ or NULLHANDLE.
*
* Side effects:
* None
*
*----------------------------------------------------------------------
*/
HMQ
TclOS2GetHMQ(HAB hab)
{
#ifdef VERBOSE
printf("TclOS2GetHMQ returning %x\n", tclHmq);
#endif
return tclHmq;
}
/*
*----------------------------------------------------------------------
*
* TclPlatformExit --
*
* Cleanup and exit on OS/2.
*
* Results:
* None. This procedure never returns (it exits the process when
* it's done).
*
* Side effects:
* This procedure terminates all relations with PM.
*
*----------------------------------------------------------------------
*/
void
TclPlatformExit(status)
int status; /* Status to exit with */
{
#ifdef VERBOSE
printf("opened files not closed yet: %d\n", openedFiles);
#endif
if (usePm) {
/*
* The MLE of the Terminal edit window doesn't restore the pointer
* when the 'exit' command is typed. Force it to be shown.
*/
#ifdef VERBOSE
printf("Showing pointer...\n");
#endif
WinShowPointer(HWND_DESKTOP, TRUE);
WinDestroyMsgQueue(tclHmq);
tclHmq= (HMQ)0;
WinTerminate(tclHab);
tclHab= (HAB)0;
}
exit(status);
}
/*
*----------------------------------------------------------------------
*
* TclOS2GetUsePm --
*
* Get the value of the DLL's usePm value
*
* Results:
* Value of usePm (Bool).
*
* Side effects:
* None
*
*----------------------------------------------------------------------
*/
BOOL
TclOS2GetUsePm(void)
{
#ifdef VERBOSE
printf("TclOS2GetUsePm: %d\n", usePm);
#endif
return usePm;
}
/*
*----------------------------------------------------------------------
*
* TclOS2SetUsePm --
*
* Set the value of the DLL's usePm value
*
* Results:
* None.
*
* Side effects:
* Sets the DLL's usePm variable.
*
*----------------------------------------------------------------------
*/
void
TclOS2SetUsePm(value)
BOOL value;
{
#ifdef VERBOSE
printf("TclOS2SetUsePm: %d and %d => ", usePm, value);
#endif
usePm = value;
#ifdef VERBOSE
printf("%d\n", usePm);
#endif
return;
}