/*
* tclMacInit.c --
*
* Contains the Mac-specific interpreter initialization functions.
*
* Copyright (c) 1995-1998 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tclMacInit.c,v 1.9.2.2 2005/10/23 22:01:31 msofer Exp $
*/
#include <AppleEvents.h>
#include <AEDataModel.h>
#include <AEObjects.h>
#include <AEPackObject.h>
#include <AERegistry.h>
#include <Files.h>
#include <Folders.h>
#include <Gestalt.h>
#include <TextUtils.h>
#include <Resources.h>
#include <Strings.h>
#include "tclInt.h"
#include "tclMacInt.h"
#include "tclPort.h"
#include "tclInitScript.h"
/*
* The following string is the startup script executed in new
* interpreters. It looks on the library path and in the resource fork 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 initCmd[] = "if {[info proc tclInit]==\"\"} {\n\
proc tclInit {} {\n\
global tcl_pkgPath env\n\
proc sourcePath {file} {\n\
foreach i $::auto_path {\n\
set init [file join $i $file.tcl]\n\
if {[catch {uplevel #0 [list source $init]}] == 0} {\n\
return\n\
}\n\
}\n\
if {[catch {uplevel #0 [list source -rsrc $file]}] == 0} {\n\
return\n\
}\n\
rename sourcePath {}\n\
set msg \"Can't find $file resource or a usable $file.tcl file\"\n\
append msg \" in the following directories:\"\n\
append msg \" $::auto_path\"\n\
append msg \" perhaps you need to install Tcl or set your\"\n\
append msg \" TCL_LIBRARY environment variable?\"\n\
error $msg\n\
}\n\
if {[info exists env(EXT_FOLDER)]} {\n\
lappend tcl_pkgPath [file join $env(EXT_FOLDER) {Tool Command Language}]\n\
}\n\
if {[info exists tcl_pkgPath] == 0} {\n\
set tcl_pkgPath {no extension folder}\n\
}\n\
sourcePath init\n\
sourcePath auto\n\
sourcePath package\n\
sourcePath history\n\
sourcePath word\n\
sourcePath parray\n\
rename sourcePath {}\n\
} }\n\
tclInit";
/*
* The following structures are used to map the script/language codes of a
* font to the name that should be passed to Tcl_GetEncoding() to obtain
* the encoding for that font. The set of numeric constants is fixed and
* defined by Apple.
*/
typedef struct Map {
int numKey;
char *strKey;
} Map;
static Map scriptMap[] = {
{smRoman, "macRoman"},
{smJapanese, "macJapan"},
{smTradChinese, "macChinese"},
{smKorean, "macKorean"},
{smArabic, "macArabic"},
{smHebrew, "macHebrew"},
{smGreek, "macGreek"},
{smCyrillic, "macCyrillic"},
{smRSymbol, "macRSymbol"},
{smDevanagari, "macDevanagari"},
{smGurmukhi, "macGurmukhi"},
{smGujarati, "macGujarati"},
{smOriya, "macOriya"},
{smBengali, "macBengali"},
{smTamil, "macTamil"},
{smTelugu, "macTelugu"},
{smKannada, "macKannada"},
{smMalayalam, "macMalayalam"},
{smSinhalese, "macSinhalese"},
{smBurmese, "macBurmese"},
{smKhmer, "macKhmer"},
{smThai, "macThailand"},
{smLaotian, "macLaos"},
{smGeorgian, "macGeorgia"},
{smArmenian, "macArmenia"},
{smSimpChinese, "macSimpChinese"},
{smTibetan, "macTIbet"},
{smMongolian, "macMongolia"},
{smGeez, "macEthiopia"},
{smEastEurRoman, "macCentEuro"},
{smVietnamese, "macVietnam"},
{smExtArabic, "macSindhi"},
{NULL, NULL}
};
static Map romanMap[] = {
{langCroatian, "macCroatian"},
{langSlovenian, "macCroatian"},
{langIcelandic, "macIceland"},
{langRomanian, "macRomania"},
{langTurkish, "macTurkish"},
{langGreek, "macGreek"},
{NULL, NULL}
};
static Map cyrillicMap[] = {
{langUkrainian, "macUkraine"},
{langBulgarian, "macBulgaria"},
{NULL, NULL}
};
static int GetFinderFont(int *finderID);
/* Used to store the encoding used for binary files */
static Tcl_Encoding binaryEncoding = NULL;
/* Has the basic library path encoding issue been fixed */
static int libraryPathEncodingFixed = 0;
/*
*----------------------------------------------------------------------
*
* GetFinderFont --
*
* Gets the "views" font of the Macintosh Finder
*
* Results:
* Standard Tcl result, and sets finderID to the font family
* id for the current finder font.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
GetFinderFont(int *finderID)
{
OSErr err = noErr;
OSType finderPrefs, viewFont = 'vfnt';
DescType returnType;
Size returnSize;
long result, sys8Mask = 0x0800;
static AppleEvent outgoingAevt = {typeNull, NULL};
AppleEvent returnAevt;
AEAddressDesc fndrAddress;
AEDesc nullContainer = {typeNull, NULL},
tempDesc = {typeNull, NULL},
tempDesc2 = {typeNull, NULL},
finalDesc = {typeNull, NULL};
const OSType finderSignature = 'MACS';
if (outgoingAevt.descriptorType == typeNull) {
if ((Gestalt(gestaltSystemVersion, &result) != noErr)
|| (result >= sys8Mask)) {
finderPrefs = 'pfrp';
} else {
finderPrefs = 'pvwp';
}
AECreateDesc(typeApplSignature, &finderSignature,
sizeof(finderSignature), &fndrAddress);
err = AECreateAppleEvent(kAECoreSuite, kAEGetData, &fndrAddress,
kAutoGenerateReturnID, kAnyTransactionID, &outgoingAevt);
AEDisposeDesc(&fndrAddress);
/*
* The structure is:
* the property view font ('vfnt')
* of the property view preferences ('pvwp')
* of the Null Container (i.e. the Finder itself).
*/
AECreateDesc(typeType, &finderPrefs, sizeof(finderPrefs), &tempDesc);
err = CreateObjSpecifier(typeType, &nullContainer, formPropertyID,
&tempDesc, true, &tempDesc2);
AECreateDesc(typeType, &viewFont, sizeof(viewFont), &tempDesc);
err = CreateObjSpecifier(typeType, &tempDesc2, formPropertyID,
&tempDesc, true, &finalDesc);
AEPutKeyDesc(&outgoingAevt, keyDirectObject, &finalDesc);
AEDisposeDesc(&finalDesc);
}
err = AESend(&outgoingAevt, &returnAevt, kAEWaitReply, kAEHighPriority,
kAEDefaultTimeout, NULL, NULL);
if (err == noErr) {
err = AEGetKeyPtr(&returnAevt, keyDirectObject, typeInteger,
&returnType, (void *) finderID, sizeof(int), &returnSize);
if (err == noErr) {
return TCL_OK;
}
}
return TCL_ERROR;
}
/*
*---------------------------------------------------------------------------
*
* TclMacGetFontEncoding --
*
* Determine the encoding of the specified font. The encoding
* can be used to convert bytes from UTF-8 into the encoding of
* that font.
*
* Results:
* The return value is a string that specifies the font's encoding
* and that can be passed to Tcl_GetEncoding() to construct the
* encoding. If the font's encoding could not be identified, NULL
* is returned.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
char *
TclMacGetFontEncoding(
int fontId)
{
int script, lang;
char *name;
Map *mapPtr;
script = FontToScript(fontId);
lang = GetScriptVariable(script, smScriptLang);
name = NULL;
if (script == smRoman) {
for (mapPtr = romanMap; mapPtr->strKey != NULL; mapPtr++) {
if (mapPtr->numKey == lang) {
name = mapPtr->strKey;
break;
}
}
} else if (script == smCyrillic) {
for (mapPtr = cyrillicMap; mapPtr->strKey != NULL; mapPtr++) {
if (mapPtr->numKey == lang) {
name = mapPtr->strKey;
break;
}
}
}
if (name == NULL) {
for (mapPtr = scriptMap; mapPtr->strKey != NULL; mapPtr++) {
if (mapPtr->numKey == script) {
name = mapPtr->strKey;
break;
}
}
}
return name;
}
/*
*---------------------------------------------------------------------------
*
* TclpInitPlatform --
*
* Initialize all the platform-dependant things like signals and
* floating-point error handling.
*
* Called at process initialization time.
*
* Results:
* None.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
void
TclpInitPlatform()
{
tclPlatform = TCL_PLATFORM_MAC;
}
/*
*---------------------------------------------------------------------------
*
* TclpInitLibraryPath --
*
* Initialize the library path at startup. We have a minor
* metacircular problem that we don't know the encoding of the
* operating system but we may need to talk to operating system
* to find the library directories so that we know how to talk to
* the operating system.
*
* We do not know the encoding of the operating system.
* We do know that the encoding is some multibyte encoding.
* In that multibyte encoding, the characters 0..127 are equivalent
* to ascii.
*
* So although we don't know the encoding, it's safe:
* to look for the last colon character in a path in the encoding.
* to append an ascii string to a path.
* to pass those strings back to the operating system.
*
* But any strings that we remembered before we knew the encoding of
* the operating system must be translated to UTF-8 once we know the
* encoding so that the rest of Tcl can use those strings.
*
* This call sets the library path to strings in the unknown native
* encoding. TclpSetInitialEncodings() will translate the library
* path from the native encoding to UTF-8 as soon as it determines
* what the native encoding actually is.
*
* Called at process initialization time.
*
* Results:
* Return 1, indicating that the UTF may be dirty and require "cleanup"
* after encodings are initialized.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
int
TclpInitLibraryPath(argv0)
CONST char *argv0; /* Name of executable from argv[0] to main().
* Not used because we can determine the name
* by querying the module handle. */
{
Tcl_Obj *objPtr, *pathPtr;
CONST char *str;
Tcl_DString ds;
TclMacCreateEnv();
pathPtr = Tcl_NewObj();
/*
* Look for the library relative to default encoding dir.
*/
str = Tcl_GetDefaultEncodingDir();
if ((str != NULL) && (str[0] != '\0')) {
objPtr = Tcl_NewStringObj(str, -1);
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
}
str = TclGetEnv("TCL_LIBRARY", &ds);
if ((str != NULL) && (str[0] != '\0')) {
/*
* If TCL_LIBRARY is set, search there.
*/
objPtr = Tcl_NewStringObj(str, Tcl_DStringLength(&ds));
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
Tcl_DStringFree(&ds);
}
objPtr = TclGetLibraryPath();
if (objPtr != NULL) {
Tcl_ListObjAppendList(NULL, pathPtr, objPtr);
}
/*
* lappend path [file join $env(EXT_FOLDER) \
* "Tool Command Language" "tcl[info version]"
*/
str = TclGetEnv("EXT_FOLDER", &ds);
if ((str != NULL) && (str[0] != '\0')) {
Tcl_DString libPath, path;
CONST char *argv[3];
argv[0] = str;
argv[1] = "Tool Command Language";
Tcl_DStringInit(&libPath);
Tcl_DStringAppend(&libPath, "tcl", -1);
argv[2] = Tcl_DStringAppend(&libPath, TCL_VERSION, -1);
Tcl_DStringInit(&path);
str = Tcl_JoinPath(3, argv, &path);
objPtr = Tcl_NewStringObj(str, Tcl_DStringLength(&path));
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
Tcl_DStringFree(&ds);
Tcl_DStringFree(&libPath);
Tcl_DStringFree(&path);
}
TclSetLibraryPath(pathPtr);
return 1; /* 1 indicates that pathPtr may be dirty utf (needs cleaning) */
}
/*
*---------------------------------------------------------------------------
*
* TclpSetInitialEncodings --
*
* Based on the locale, determine the encoding of the operating
* system and the default encoding for newly opened files.
*
* Called at process initialization time, and part way through
* startup, we verify that the initial encodings were correctly
* setup. Depending on Tcl's environment, there may not have been
* enough information first time through (above).
*
* Results:
* None.
*
* Side effects:
* The Tcl library path is converted from native encoding to UTF-8,
* on the first call, and the encodings may be changed on first or
* second call.
*
*---------------------------------------------------------------------------
*/
void
TclpSetInitialEncodings()
{
CONST char *encoding;
Tcl_Obj *pathPtr;
int fontId, err;
fontId = 0;
GetFinderFont(&fontId);
encoding = TclMacGetFontEncoding(fontId);
if (encoding == NULL) {
encoding = "macRoman";
}
err = Tcl_SetSystemEncoding(NULL, encoding);
if (err == TCL_OK && libraryPathEncodingFixed == 0) {
/*
* Until the system encoding was actually set, the library path was
* actually in the native multi-byte encoding, and not really UTF-8
* as advertised. We cheated as follows:
*
* 1. It was safe to allow the Tcl_SetSystemEncoding() call to
* append the ASCII chars that make up the encoding's filename to
* the names (in the native encoding) of directories in the library
* path, since all Unix multi-byte encodings have ASCII in the
* beginning.
*
* 2. To open the encoding file, the native bytes in the file name
* were passed to the OS, without translating from UTF-8 to native,
* because the name was already in the native encoding.
*
* Now that the system encoding was actually successfully set,
* translate all the names in the library path to UTF-8. That way,
* next time we search the library path, we'll translate the names
* from UTF-8 to the system encoding which will be the native
* encoding.
*/
pathPtr = TclGetLibraryPath();
if (pathPtr != NULL) {
int i, objc;
Tcl_Obj **objv;
objc = 0;
Tcl_ListObjGetElements(NULL, pathPtr, &objc, &objv);
for (i = 0; i < objc; i++) {
int length;
char *string;
Tcl_DString ds;
string = Tcl_GetStringFromObj(objv[i], &length);
Tcl_ExternalToUtfDString(NULL, string, length, &ds);
Tcl_SetStringObj(objv[i], Tcl_DStringValue(&ds),
Tcl_DStringLength(&ds));
Tcl_DStringFree(&ds);
}
Tcl_InvalidateStringRep(pathPtr);
}
libraryPathEncodingFixed = 1;
}
/* This is only ever called from the startup thread */
if (binaryEncoding == NULL) {
/*
* Keep the iso8859-1 encoding preloaded. The IO package uses
* it for gets on a binary channel.
*/
binaryEncoding = Tcl_GetEncoding(NULL, "iso8859-1");
}
}
/*
*---------------------------------------------------------------------------
*
* TclpSetVariables --
*
* Performs platform-specific interpreter initialization related to
* the tcl_library and tcl_platform variables, and other platform-
* specific things.
*
* Results:
* None.
*
* Side effects:
* Sets "tcl_library" and "tcl_platform" Tcl variables.
*
*----------------------------------------------------------------------
*/
void
TclpSetVariables(interp)
Tcl_Interp *interp;
{
long int gestaltResult;
int minor, major, objc;
Tcl_Obj **objv;
char versStr[2 * TCL_INTEGER_SPACE];
CONST char *str;
Tcl_Obj *pathPtr;
Tcl_DString ds;
str = "no library";
pathPtr = TclGetLibraryPath();
if (pathPtr != NULL) {
objc = 0;
Tcl_ListObjGetElements(NULL, pathPtr, &objc, &objv);
if (objc > 0) {
str = Tcl_GetStringFromObj(objv[0], NULL);
}
}
Tcl_SetVar(interp, "tcl_library", str, TCL_GLOBAL_ONLY);
if (pathPtr != NULL) {
Tcl_SetVar2Ex(interp, "tcl_pkgPath", NULL, pathPtr, TCL_GLOBAL_ONLY);
}
Tcl_SetVar2(interp, "tcl_platform", "platform", "macintosh",
TCL_GLOBAL_ONLY);
Tcl_SetVar2(interp, "tcl_platform", "os", "MacOS", TCL_GLOBAL_ONLY);
Gestalt(gestaltSystemVersion, &gestaltResult);
major = (gestaltResult & 0x0000FF00) >> 8;
minor = (gestaltResult & 0x000000F0) >> 4;
sprintf(versStr, "%d.%d", major, minor);
Tcl_SetVar2(interp, "tcl_platform", "osVersion", versStr, TCL_GLOBAL_ONLY);
#if GENERATINGPOWERPC
Tcl_SetVar2(interp, "tcl_platform", "machine", "ppc", TCL_GLOBAL_ONLY);
#else
Tcl_SetVar2(interp, "tcl_platform", "machine", "68k", TCL_GLOBAL_ONLY);
#endif
/*
* Copy USER or LOGIN environment variable into tcl_platform(user)
* These are set by SystemVariables in tclMacEnv.c
*/
Tcl_DStringInit(&ds);
str = TclGetEnv("USER", &ds);
if (str == NULL) {
str = TclGetEnv("LOGIN", &ds);
if (str == NULL) {
str = "";
}
}
Tcl_SetVar2(interp, "tcl_platform", "user", str, TCL_GLOBAL_ONLY);
Tcl_DStringFree(&ds);
}
/*
*----------------------------------------------------------------------
*
* TclpCheckStackSpace --
*
* On a 68K Mac, we can detect if we are about to blow the stack.
* Called before an evaluation can happen when nesting depth is
* checked.
*
* Results:
* 1 if there is enough stack space to continue; 0 if not.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclpCheckStackSpace()
{
return StackSpace() > TCL_MAC_STACK_THRESHOLD;
}
/*
*----------------------------------------------------------------------
*
* TclpFindVariable --
*
* Locate the entry in environ for a given name. On Unix and Macthis
* routine is case sensitive, on Windows this matches mixed case.
*
* Results:
* The return value is the index in environ of an entry with the
* name "name", or -1 if there is no such entry. The integer at
* *lengthPtr is filled in with the length of name (if a matching
* entry is found) or the length of the environ array (if no matching
* entry is found).
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclpFindVariable(name, lengthPtr)
CONST char *name; /* Name of desired environment variable
* (native). */
int *lengthPtr; /* Used to return length of name (for
* successful searches) or number of non-NULL
* entries in environ (for unsuccessful
* searches). */
{
int i, result = -1;
register CONST char *env, *p1, *p2;
Tcl_DString envString;
Tcl_DStringInit(&envString);
for (i = 0, env = environ[i]; env != NULL; i++, env = environ[i]) {
p1 = Tcl_ExternalToUtfDString(NULL, env, -1, &envString);
p2 = name;
for (; *p2 == *p1; p1++, p2++) {
/* NULL loop body. */
}
if ((*p1 == '=') && (*p2 == '\0')) {
*lengthPtr = p2 - name;
result = i;
goto done;
}
Tcl_DStringFree(&envString);
}
*lengthPtr = i;
done:
Tcl_DStringFree(&envString);
return result;
}
/*
*----------------------------------------------------------------------
*
* 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 the interp's result
* if there is an error.
*
* Side effects:
* Depends on what's in the init.tcl script.
*
*----------------------------------------------------------------------
*/
int
Tcl_Init(
Tcl_Interp *interp) /* Interpreter to initialize. */
{
Tcl_Obj *pathPtr;
if (tclPreInitScript != NULL) {
if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) {
return (TCL_ERROR);
};
}
/*
* For Macintosh applications the Init function may be contained in
* the application resources. If it exists we use it - otherwise we
* look in the tcl_library directory. Ditto for the history command.
*/
pathPtr = TclGetLibraryPath();
if (pathPtr == NULL) {
pathPtr = Tcl_NewObj();
}
Tcl_IncrRefCount(pathPtr);
Tcl_SetVar2Ex(interp, "auto_path", NULL, pathPtr, TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(pathPtr);
return Tcl_Eval(interp, initCmd);
}
/*
*----------------------------------------------------------------------
*
* Tcl_SourceRCFile --
*
* This procedure is typically invoked by Tcl_Main or Tk_Main
* procedure to source an application specific rc file into the
* interpreter at startup time. This will either source a file
* in the "tcl_rcFileName" variable or a TEXT resource in the
* "tcl_rcRsrcName" variable.
*
* Results:
* None.
*
* Side effects:
* Depends on what's in the rc script.
*
*----------------------------------------------------------------------
*/
void
Tcl_SourceRCFile(
Tcl_Interp *interp) /* Interpreter to source rc file into. */
{
Tcl_DString temp;
CONST char *fileName;
Tcl_Channel errChannel;
Handle h;
fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY);
if (fileName != NULL) {
Tcl_Channel c;
CONST 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) {
errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errChannel) {
Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
Tcl_WriteChars(errChannel, "\n", 1);
}
}
}
}
Tcl_DStringFree(&temp);
}
fileName = Tcl_GetVar(interp, "tcl_rcRsrcName", TCL_GLOBAL_ONLY);
if (fileName != NULL) {
Str255 rezName;
Tcl_DString ds;
Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
strcpy((char *) rezName + 1, Tcl_DStringValue(&ds));
rezName[0] = (unsigned) Tcl_DStringLength(&ds);
h = GetNamedResource('TEXT', rezName);
Tcl_DStringFree(&ds);
if (h != NULL) {
if (Tcl_MacEvalResource(interp, fileName, 0, NULL) != TCL_OK) {
errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errChannel) {
Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
Tcl_WriteChars(errChannel, "\n", 1);
}
}
Tcl_ResetResult(interp);
ReleaseResource(h);
}
}
}
syntax highlighted by Code2HTML, v. 0.9.1