diff options
Diffstat (limited to 'unix/tclUnixInit.c')
| -rw-r--r-- | unix/tclUnixInit.c | 1470 |
1 files changed, 682 insertions, 788 deletions
diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index f9015b7..5de9e48 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -1,4 +1,4 @@ -/* +/* * tclUnixInit.c -- * * Contains the Unix-specific interpreter initialization functions. @@ -8,8 +8,11 @@ * All rights reserved. */ +#if defined(HAVE_COREFOUNDATION) +#include <CoreFoundation/CoreFoundation.h> +#endif #include "tclInt.h" -#include <stddef.h> +#include "tclPort.h" #include <locale.h> #ifdef HAVE_LANGINFO # include <langinfo.h> @@ -21,7 +24,6 @@ # endif # endif #endif -#include <sys/resource.h> #if defined(__FreeBSD__) && defined(__GNUC__) # include <floatingpoint.h> #endif @@ -76,72 +78,22 @@ typedef struct _OSVERSIONINFOA { } OSVERSIONINFOA; #endif -#ifdef HAVE_COREFOUNDATION -#include <CoreFoundation/CoreFoundation.h> -#endif - -/* - * Define TCL_NO_STACK_CHECK in the compiler options if you want to revert to - * the old behavior of never checking the stack. - */ - -/* - * Define this if you want to see a lot of output regarding stack checking. - */ - -#undef TCL_DEBUG_STACK_CHECK - -/* - * Values used to compute how much space is really available for Tcl's use for - * the stack. - * - * The getrlimit() function is documented to return the maximum stack size in - * bytes. However, with threads enabled, the pthread library on some platforms - * does bad things to the stack size limits. First, the limits cannot be - * changed. Second, they appear to be sometimes reported incorrectly. - * - * The defines below may need to be adjusted if more platforms have this - * broken behavior with threads enabled. - */ - -#ifndef TCL_MAGIC_STACK_DIVISOR -#define TCL_MAGIC_STACK_DIVISOR 1 -#endif -#ifndef TCL_RESERVED_STACK_PAGES -#define TCL_RESERVED_STACK_PAGES 8 -#endif /* - * Thread specific data for stack checking. + * The Init script (common to Windows and Unix platforms) is + * defined in tkInitScript.h */ +#include "tclInitScript.h" -#ifndef TCL_NO_STACK_CHECK -typedef struct ThreadSpecificData { - int *outerVarPtr; /* The "outermost" stack frame pointer for - * this thread. */ - int *stackBound; /* The current stack boundary */ -} ThreadSpecificData; -static Tcl_ThreadDataKey dataKey; -#ifdef TCL_CROSS_COMPILE -static int stackGrowsDown = -1; -static int StackGrowsDown(int *parent); -#elif defined(TCL_STACK_GROWS_UP) -#define stackGrowsDown 0 -#else -#define stackGrowsDown 1 -#endif -#endif /* TCL_NO_STACK_CHECK */ - -#ifdef TCL_DEBUG_STACK_CHECK -#define STACK_DEBUG(args) printf args -#else -#define STACK_DEBUG(args) (void)0 -#endif /* TCL_DEBUG_STACK_CHECK */ +/* 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; /* - * Tcl tries to use standard and homebrew methods to guess the right encoding - * on the platform. However, there is always a final fallback, and this value - * is it. Make sure it is a real Tcl encoding. + * Tcl tries to use standard and homebrew methods to guess the right + * encoding on the platform. However, there is always a final fallback, + * and this value is it. Make sure it is a real Tcl encoding. */ #ifndef TCL_DEFAULT_ENCODING @@ -149,25 +101,26 @@ static int StackGrowsDown(int *parent); #endif /* - * Default directory in which to look for Tcl library scripts. The symbol is - * defined by Makefile. + * Default directory in which to look for Tcl library scripts. The + * symbol is defined by Makefile. */ static char defaultLibraryDir[sizeof(TCL_LIBRARY)+200] = TCL_LIBRARY; /* * Directory in which to look for packages (each package is typically - * installed as a subdirectory of this directory). The symbol is defined by - * Makefile. + * installed as a subdirectory of this directory). The symbol is + * defined by Makefile. */ static char pkgPath[sizeof(TCL_PACKAGE_PATH)+200] = TCL_PACKAGE_PATH; /* - * The following table is used to map from Unix locale strings to encoding - * files. If HAVE_LANGINFO is defined, then this is a fallback table when the - * result from nl_langinfo isn't a recognized encoding. Otherwise this is the - * first list checked for a mapping from env encoding to Tcl encoding name. + * The following table is used to map from Unix locale strings to + * encoding files. If HAVE_LANGINFO is defined, then this is a fallback + * table when the result from nl_langinfo isn't a recognized encoding. + * Otherwise this is the first list checked for a mapping from env + * encoding to Tcl encoding name. */ typedef struct LocaleTable { @@ -175,207 +128,78 @@ typedef struct LocaleTable { CONST char *encoding; } LocaleTable; -/* - * The table below is sorted for the sake of doing binary searches on it. The - * indenting reflects different categories of data. The leftmost data - * represent the encoding names directly implemented by data files in Tcl's - * default encoding directory. Indented by one TAB are the encoding names that - * are common alternative spellings. Indented by two TABs are the accumulated - * "bug fixes" that have been added to deal with the wide variability seen - * among existing platforms. - */ - static CONST LocaleTable localeTable[] = { - {"", "iso8859-1"}, - {"ansi-1251", "cp1251"}, - {"ansi_x3.4-1968", "iso8859-1"}, - {"ascii", "ascii"}, - {"big5", "big5"}, - {"cp1250", "cp1250"}, - {"cp1251", "cp1251"}, - {"cp1252", "cp1252"}, - {"cp1253", "cp1253"}, - {"cp1254", "cp1254"}, - {"cp1255", "cp1255"}, - {"cp1256", "cp1256"}, - {"cp1257", "cp1257"}, - {"cp1258", "cp1258"}, - {"cp437", "cp437"}, - {"cp737", "cp737"}, - {"cp775", "cp775"}, - {"cp850", "cp850"}, - {"cp852", "cp852"}, - {"cp855", "cp855"}, - {"cp857", "cp857"}, - {"cp860", "cp860"}, - {"cp861", "cp861"}, - {"cp862", "cp862"}, - {"cp863", "cp863"}, - {"cp864", "cp864"}, - {"cp865", "cp865"}, - {"cp866", "cp866"}, - {"cp869", "cp869"}, - {"cp874", "cp874"}, - {"cp932", "cp932"}, - {"cp936", "cp936"}, - {"cp949", "cp949"}, - {"cp950", "cp950"}, - {"dingbats", "dingbats"}, - {"ebcdic", "ebcdic"}, - {"euc-cn", "euc-cn"}, - {"euc-jp", "euc-jp"}, - {"euc-kr", "euc-kr"}, - {"eucjp", "euc-jp"}, - {"euckr", "euc-kr"}, - {"euctw", "euc-cn"}, - {"gb12345", "gb12345"}, - {"gb1988", "gb1988"}, - {"gb2312", "gb2312"}, - {"gb2312-1980", "gb2312"}, - {"gb2312-raw", "gb2312-raw"}, - {"greek8", "cp869"}, - {"ibm1250", "cp1250"}, - {"ibm1251", "cp1251"}, - {"ibm1252", "cp1252"}, - {"ibm1253", "cp1253"}, - {"ibm1254", "cp1254"}, - {"ibm1255", "cp1255"}, - {"ibm1256", "cp1256"}, - {"ibm1257", "cp1257"}, - {"ibm1258", "cp1258"}, - {"ibm437", "cp437"}, - {"ibm737", "cp737"}, - {"ibm775", "cp775"}, - {"ibm850", "cp850"}, - {"ibm852", "cp852"}, - {"ibm855", "cp855"}, - {"ibm857", "cp857"}, - {"ibm860", "cp860"}, - {"ibm861", "cp861"}, - {"ibm862", "cp862"}, - {"ibm863", "cp863"}, - {"ibm864", "cp864"}, - {"ibm865", "cp865"}, - {"ibm866", "cp866"}, - {"ibm869", "cp869"}, - {"ibm874", "cp874"}, - {"ibm932", "cp932"}, - {"ibm936", "cp936"}, - {"ibm949", "cp949"}, - {"ibm950", "cp950"}, - {"iso-2022", "iso2022"}, - {"iso-2022-jp", "iso2022-jp"}, - {"iso-2022-kr", "iso2022-kr"}, - {"iso-8859-1", "iso8859-1"}, - {"iso-8859-10", "iso8859-10"}, - {"iso-8859-13", "iso8859-13"}, - {"iso-8859-14", "iso8859-14"}, - {"iso-8859-15", "iso8859-15"}, - {"iso-8859-16", "iso8859-16"}, - {"iso-8859-2", "iso8859-2"}, - {"iso-8859-3", "iso8859-3"}, - {"iso-8859-4", "iso8859-4"}, - {"iso-8859-5", "iso8859-5"}, - {"iso-8859-6", "iso8859-6"}, - {"iso-8859-7", "iso8859-7"}, - {"iso-8859-8", "iso8859-8"}, - {"iso-8859-9", "iso8859-9"}, - {"iso2022", "iso2022"}, - {"iso2022-jp", "iso2022-jp"}, - {"iso2022-kr", "iso2022-kr"}, - {"iso8859-1", "iso8859-1"}, - {"iso8859-10", "iso8859-10"}, - {"iso8859-13", "iso8859-13"}, - {"iso8859-14", "iso8859-14"}, - {"iso8859-15", "iso8859-15"}, - {"iso8859-16", "iso8859-16"}, - {"iso8859-2", "iso8859-2"}, - {"iso8859-3", "iso8859-3"}, - {"iso8859-4", "iso8859-4"}, - {"iso8859-5", "iso8859-5"}, - {"iso8859-6", "iso8859-6"}, - {"iso8859-7", "iso8859-7"}, - {"iso8859-8", "iso8859-8"}, - {"iso8859-9", "iso8859-9"}, - {"iso88591", "iso8859-1"}, - {"iso885915", "iso8859-15"}, - {"iso88592", "iso8859-2"}, - {"iso88595", "iso8859-5"}, - {"iso88596", "iso8859-6"}, - {"iso88597", "iso8859-7"}, - {"iso88598", "iso8859-8"}, - {"iso88599", "iso8859-9"}, -#ifdef hpux - {"ja", "shiftjis"}, -#else - {"ja", "euc-jp"}, -#endif - {"ja_jp", "euc-jp"}, - {"ja_jp.euc", "euc-jp"}, - {"ja_jp.eucjp", "euc-jp"}, - {"ja_jp.jis", "iso2022-jp"}, - {"ja_jp.mscode", "shiftjis"}, - {"ja_jp.sjis", "shiftjis"}, - {"ja_jp.ujis", "euc-jp"}, - {"japan", "euc-jp"}, +#ifdef HAVE_LANGINFO + {"gb2312-1980", "gb2312"}, + {"ansi-1251", "cp1251"}, /* Solaris gets this wrong. */ +#ifdef __hpux + {"SJIS", "shiftjis"}, + {"eucjp", "euc-jp"}, + {"euckr", "euc-kr"}, + {"euctw", "euc-cn"}, + {"greek8", "cp869"}, + {"iso88591", "iso8859-1"}, + {"iso88592", "iso8859-2"}, + {"iso88595", "iso8859-5"}, + {"iso88596", "iso8859-6"}, + {"iso88597", "iso8859-7"}, + {"iso88598", "iso8859-8"}, + {"iso88599", "iso8859-9"}, + {"iso885915", "iso8859-15"}, + {"roman8", "iso8859-1"}, + {"tis620", "tis-620"}, + {"turkish8", "cp857"}, + {"utf8", "utf-8"}, +#endif /* __hpux */ +#endif /* HAVE_LANGINFO */ + + {"ja_JP.SJIS", "shiftjis"}, + {"ja_JP.EUC", "euc-jp"}, + {"ja_JP.eucJP", "euc-jp"}, + {"ja_JP.JIS", "iso2022-jp"}, + {"ja_JP.mscode", "shiftjis"}, + {"ja_JP.ujis", "euc-jp"}, + {"ja_JP", "euc-jp"}, + {"Ja_JP", "shiftjis"}, + {"Jp_JP", "shiftjis"}, + {"japan", "euc-jp"}, #ifdef hpux - {"japanese", "shiftjis"}, + {"japanese", "shiftjis"}, + {"ja", "shiftjis"}, #else - {"japanese", "euc-jp"}, + {"japanese", "euc-jp"}, + {"ja", "euc-jp"}, #endif - {"japanese-sjis", "shiftjis"}, - {"japanese-ujis", "euc-jp"}, - {"japanese.euc", "euc-jp"}, - {"japanese.sjis", "shiftjis"}, - {"jis0201", "jis0201"}, - {"jis0208", "jis0208"}, - {"jis0212", "jis0212"}, - {"jp_jp", "shiftjis"}, - {"ko", "euc-kr"}, - {"ko_kr", "euc-kr"}, - {"ko_kr.euc", "euc-kr"}, - {"ko_kw.euckw", "euc-kr"}, - {"koi8-r", "koi8-r"}, - {"koi8-u", "koi8-u"}, - {"korean", "euc-kr"}, - {"ksc5601", "ksc5601"}, - {"maccenteuro", "macCentEuro"}, - {"maccroatian", "macCroatian"}, - {"maccyrillic", "macCyrillic"}, - {"macdingbats", "macDingbats"}, - {"macgreek", "macGreek"}, - {"maciceland", "macIceland"}, - {"macjapan", "macJapan"}, - {"macroman", "macRoman"}, - {"macromania", "macRomania"}, - {"macthai", "macThai"}, - {"macturkish", "macTurkish"}, - {"macukraine", "macUkraine"}, - {"roman8", "iso8859-1"}, - {"ru", "iso8859-5"}, - {"ru_ru", "iso8859-5"}, - {"ru_su", "iso8859-5"}, - {"shiftjis", "shiftjis"}, - {"sjis", "shiftjis"}, - {"symbol", "symbol"}, - {"tis-620", "tis-620"}, - {"tis620", "tis-620"}, - {"turkish8", "cp857"}, - {"utf8", "utf-8"}, - {"zh", "cp936"}, - {"zh_cn.gb2312", "euc-cn"}, - {"zh_cn.gbk", "euc-cn"}, - {"zh_cz.gb2312", "euc-cn"}, - {"zh_tw", "euc-tw"}, - {"zh_tw.big5", "big5"}, + {"japanese.sjis", "shiftjis"}, + {"japanese.euc", "euc-jp"}, + {"japanese-sjis", "shiftjis"}, + {"japanese-ujis", "euc-jp"}, + + {"ko", "euc-kr"}, + {"ko_KR", "euc-kr"}, + {"ko_KR.EUC", "euc-kr"}, + {"ko_KR.euc", "euc-kr"}, + {"ko_KR.eucKR", "euc-kr"}, + {"korean", "euc-kr"}, + + {"ru", "iso8859-5"}, + {"ru_RU", "iso8859-5"}, + {"ru_SU", "iso8859-5"}, + + {"zh", "cp936"}, + {"zh_CN.gb2312", "euc-cn"}, + {"zh_CN.GB2312", "euc-cn"}, + {"zh_CN.GBK", "euc-cn"}, + {"zh_TW.Big5", "big5"}, + {"zh_TW", "euc-tw"}, + + {NULL, NULL} }; -#ifndef TCL_NO_STACK_CHECK -static int GetStackSize(size_t *stackSizePtr); -#endif /* TCL_NO_STACK_CHECK */ #ifdef HAVE_COREFOUNDATION -static int MacOSXGetLibraryPath(Tcl_Interp *interp, - int maxPathLen, char *tclLibPath); +static int MacOSXGetLibraryPath _ANSI_ARGS_(( + Tcl_Interp *interp, int maxPathLen, + char *tclLibPath)); #endif /* HAVE_COREFOUNDATION */ #if defined(__APPLE__) && (defined(TCL_LOAD_FROM_MEMORY) || ( \ defined(MAC_OS_X_VERSION_MIN_REQUIRED) && ( \ @@ -388,7 +212,6 @@ static int MacOSXGetLibraryPath(Tcl_Interp *interp, * initialize release global at startup from uname(). */ #define GET_DARWIN_RELEASE 1 -MODULE_SCOPE long tclMacOSXDarwinRelease; long tclMacOSXDarwinRelease = 0; #endif @@ -413,18 +236,13 @@ long tclMacOSXDarwinRelease = 0; */ void -TclpInitPlatform(void) +TclpInitPlatform() { -#ifdef DJGPP - tclPlatform = TCL_PLATFORM_WINDOWS; -#else tclPlatform = TCL_PLATFORM_UNIX; -#endif /* * Make sure, that the standard FDs exist. [Bug 772288] */ - if (TclOSseek(0, (Tcl_SeekOffset) 0, SEEK_CUR) == -1 && errno == EBADF) { open("/dev/null", O_RDONLY); } @@ -436,12 +254,13 @@ TclpInitPlatform(void) } /* - * The code below causes SIGPIPE (broken pipe) errors to be ignored. This - * is needed so that Tcl processes don't die if they create child - * processes (e.g. using "exec" or "open") that terminate prematurely. - * The signal handler is only set up when the first interpreter is - * created; after this the application can override the handler with a - * different one of its own, if it wants. + * The code below causes SIGPIPE (broken pipe) errors to + * be ignored. This is needed so that Tcl processes don't + * die if they create child processes (e.g. using "exec" or + * "open") that terminate prematurely. The signal handler + * is only set up when the first interpreter is created; + * after this the application can override the handler with + * a different one of its own, if it wants. */ #ifdef SIGPIPE @@ -457,41 +276,19 @@ TclpInitPlatform(void) */ fpsetround(FP_RN); - (void) fpsetmask(0L); + fpsetmask(0L); #endif #if defined(__bsdi__) && (_BSDI_VERSION > 199501) /* * Find local symbols. Don't report an error if we fail. */ - - (void) dlopen(NULL, RTLD_NOW); /* INTL: Native. */ + (void) dlopen (NULL, RTLD_NOW); /* INTL: Native. */ #endif - /* - * Initialize the C library's locale subsystem. This is required for input - * methods to work properly on X11. We only do this for LC_CTYPE because - * that's the necessary one, and we don't want to affect LC_TIME here. - * The side effect of setting the default locale should be to load any - * locale specific modules that are needed by X. [BUG: 5422 3345 4236 2522 - * 2521]. - */ - - setlocale(LC_CTYPE, ""); - - /* - * In case the initial locale is not "C", ensure that the numeric - * processing is done in "C" locale regardless. This is needed because Tcl - * relies on routines like strtod, but should not have locale dependent - * behavior. - */ - - setlocale(LC_NUMERIC, "C"); - #ifdef GET_DARWIN_RELEASE { struct utsname name; - if (!uname(&name)) { tclMacOSXDarwinRelease = strtol(name.release, NULL, 10); } @@ -504,62 +301,95 @@ TclpInitPlatform(void) * * TclpInitLibraryPath -- * - * This is the fallback routine that sets the library path if the - * application has not set one by the first time it is needed. + * 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 slash 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: - * None. + * Return 1, indicating that the UTF may be dirty and require "cleanup" + * after encodings are initialized. * * Side effects: - * Sets the library path to an initial value. + * None. * - *------------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ -void -TclpInitLibraryPath( - char **valuePtr, - int *lengthPtr, - Tcl_Encoding *encodingPtr) +int +TclpInitLibraryPath(path) +CONST char *path; /* Path to the executable in native + * multi-byte encoding. */ { #define LIBRARY_SIZE 32 Tcl_Obj *pathPtr, *objPtr; CONST char *str; - Tcl_DString buffer; + Tcl_DString buffer, ds; + int pathc; + CONST char **pathv; + char installLib[LIBRARY_SIZE], developLib[LIBRARY_SIZE]; + Tcl_DStringInit(&ds); pathPtr = Tcl_NewObj(); /* - * Look for the library relative to the TCL_LIBRARY env variable. If the - * last dirname in the TCL_LIBRARY path does not match the last dirname in - * the installLib variable, use the last dir name of installLib in - * addition to the orginal TCL_LIBRARY path. + * Initialize the substrings used when locating an executable. The + * installLib variable computes the path as though the executable + * is installed. The developLib computes the path as though the + * executable is run from a develpment directory. */ + + sprintf(installLib, "lib/tcl%s", TCL_VERSION); + sprintf(developLib, "tcl%s/library", TCL_PATCH_LEVEL); - str = getenv("TCL_LIBRARY"); /* INTL: Native. */ - Tcl_ExternalToUtfDString(NULL, str, -1, &buffer); - str = Tcl_DStringValue(&buffer); + /* + * Look for the library relative to default encoding dir. + */ + str = Tcl_GetDefaultEncodingDir(); if ((str != NULL) && (str[0] != '\0')) { - Tcl_DString ds; - int pathc; - CONST char **pathv; - char installLib[LIBRARY_SIZE]; - - Tcl_DStringInit(&ds); + objPtr = Tcl_NewStringObj(str, -1); + Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); + } - /* - * Initialize the substrings used when locating an executable. The - * installLib variable computes the path as though the executable is - * installed. - */ + /* + * Look for the library relative to the TCL_LIBRARY env variable. + * If the last dirname in the TCL_LIBRARY path does not match the + * last dirname in the installLib variable, use the last dir name + * of installLib in addition to the orginal TCL_LIBRARY path. + */ - sprintf(installLib, "lib/tcl%s", TCL_VERSION); + str = getenv("TCL_LIBRARY"); /* INTL: Native. */ + Tcl_ExternalToUtfDString(NULL, str, -1, &buffer); + str = Tcl_DStringValue(&buffer); + if ((str != NULL) && (str[0] != '\0')) { /* * If TCL_LIBRARY is set, search there. */ - + objPtr = Tcl_NewStringObj(str, -1); Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); @@ -569,10 +399,10 @@ TclpInitLibraryPath( * If TCL_LIBRARY is set but refers to a different tcl * installation than the current version, try fiddling with the * specified directory to make it refer to this installation by - * removing the old "tclX.Y" and substituting the current version - * string. + * removing the old "tclX.Y" and substituting the current + * version string. */ - + pathv[pathc - 1] = installLib + 4; str = Tcl_JoinPath(pathc, pathv, &ds); objPtr = Tcl_NewStringObj(str, Tcl_DStringLength(&ds)); @@ -583,38 +413,136 @@ TclpInitLibraryPath( } /* - * Finally, look for the library relative to the compiled-in path. This is - * needed when users install Tcl with an exec-prefix that is different - * from the prefix. + * Look for the library relative to the executable. This algorithm + * should be the same as the one in the tcl_findLibrary procedure. + * + * This code looks in the following directories: + * + * <bindir>/../<installLib> + * (e.g. /usr/local/bin/../lib/tcl8.4) + * <bindir>/../../<installLib> + * (e.g. /usr/local/TclPro/solaris-sparc/bin/../../lib/tcl8.4) + * <bindir>/../library + * (e.g. /usr/src/tcl8.4.0/unix/../library) + * <bindir>/../../library + * (e.g. /usr/src/tcl8.4.0/unix/solaris-sparc/../../library) + * <bindir>/../../<developLib> + * (e.g. /usr/src/tcl8.4.0/unix/../../tcl8.4.0/library) + * <bindir>/../../../<developLib> + * (e.g. /usr/src/tcl8.4.0/unix/solaris-sparc/../../../tcl8.4.0/library) + */ + + + /* + * The variable path holds an absolute path. Take care not to + * overwrite pathv[0] since that might produce a relative path. + */ + + if (path != NULL) { + int i, origc; + CONST char **origv; + + Tcl_SplitPath(path, &origc, &origv); + pathc = 0; + pathv = (CONST char **) ckalloc((unsigned int)(origc * sizeof(char *))); + for (i=0; i< origc; i++) { + if (origv[i][0] == '.') { + if (strcmp(origv[i], ".") == 0) { + /* do nothing */ + } else if (strcmp(origv[i], "..") == 0) { + pathc--; + } else { + pathv[pathc++] = origv[i]; + } + } else { + pathv[pathc++] = origv[i]; + } + } + if (pathc > 2) { + str = pathv[pathc - 2]; + pathv[pathc - 2] = installLib; + path = Tcl_JoinPath(pathc - 1, pathv, &ds); + pathv[pathc - 2] = str; + objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds)); + Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); + Tcl_DStringFree(&ds); + } + if (pathc > 3) { + str = pathv[pathc - 3]; + pathv[pathc - 3] = installLib; + path = Tcl_JoinPath(pathc - 2, pathv, &ds); + pathv[pathc - 3] = str; + objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds)); + Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); + Tcl_DStringFree(&ds); + } + if (pathc > 2) { + str = pathv[pathc - 2]; + pathv[pathc - 2] = "library"; + path = Tcl_JoinPath(pathc - 1, pathv, &ds); + pathv[pathc - 2] = str; + objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds)); + Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); + Tcl_DStringFree(&ds); + } + if (pathc > 3) { + str = pathv[pathc - 3]; + pathv[pathc - 3] = "library"; + path = Tcl_JoinPath(pathc - 2, pathv, &ds); + pathv[pathc - 3] = str; + objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds)); + Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); + Tcl_DStringFree(&ds); + } + if (pathc > 3) { + str = pathv[pathc - 3]; + pathv[pathc - 3] = developLib; + path = Tcl_JoinPath(pathc - 2, pathv, &ds); + pathv[pathc - 3] = str; + objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds)); + Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); + Tcl_DStringFree(&ds); + } + if (pathc > 4) { + str = pathv[pathc - 4]; + pathv[pathc - 4] = developLib; + path = Tcl_JoinPath(pathc - 3, pathv, &ds); + pathv[pathc - 4] = str; + objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds)); + Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); + Tcl_DStringFree(&ds); + } + ckfree((char *) origv); + ckfree((char *) pathv); + } + + /* + * Finally, look for the library relative to the compiled-in path. + * This is needed when users install Tcl with an exec-prefix that + * is different from the prtefix. */ { #ifdef HAVE_COREFOUNDATION - char tclLibPath[MAXPATHLEN + 1]; + char tclLibPath[MAXPATHLEN + 1]; - if (MacOSXGetLibraryPath(NULL, MAXPATHLEN, tclLibPath) == TCL_OK) { - str = tclLibPath; - } else + if (MacOSXGetLibraryPath(NULL, MAXPATHLEN, tclLibPath) == TCL_OK) { + str = tclLibPath; + } else #endif /* HAVE_COREFOUNDATION */ - { - /* - * TODO: Pull this value from the TIP 59 table. - */ - - str = defaultLibraryDir; - } - if (str[0] != '\0') { - objPtr = Tcl_NewStringObj(str, -1); - Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); - } + { + str = defaultLibraryDir; + } + if (str[0] != '\0') { + objPtr = Tcl_NewStringObj(str, -1); + Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); } + } + + TclSetLibraryPath(pathPtr); Tcl_DStringFree(&buffer); - *encodingPtr = Tcl_GetEncoding(NULL, NULL); - str = Tcl_GetStringFromObj(pathPtr, lengthPtr); - *valuePtr = ckalloc((unsigned int) (*lengthPtr)+1); - memcpy(*valuePtr, str, (size_t)(*lengthPtr)+1); - Tcl_DecrRefCount(pathPtr); + return 1; /* 1 indicates that pathPtr may be dirty utf (needs cleaning) */ } /* @@ -622,168 +550,250 @@ TclpInitLibraryPath( * * TclpSetInitialEncodings -- * - * Based on the locale, determine the encoding of the operating system - * and the default encoding for newly opened files. + * 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). + * 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. + * 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(void) -{ - Tcl_DString encodingName; - Tcl_SetSystemEncoding(NULL, - Tcl_GetEncodingNameFromEnvironment(&encodingName)); - Tcl_DStringFree(&encodingName); -} - -void -TclpSetInterfaces(void) -{ - /* do nothing */ -} - -static CONST char * -SearchKnownEncodings( - CONST char *encoding) -{ - int left = 0; - int right = sizeof(localeTable)/sizeof(LocaleTable); - - while (left <= right) { - int test = (left + right)/2; - int code = strcmp(localeTable[test].lang, encoding); - - if (code == 0) { - return localeTable[test].encoding; - } - if (code < 0) { - left = test+1; - } else { - right = test-1; - } - } - return NULL; -} - -CONST char * -Tcl_GetEncodingNameFromEnvironment( - Tcl_DString *bufPtr) +TclpSetInitialEncodings() { - CONST char *encoding; - CONST char *knownEncoding; - - Tcl_DStringInit(bufPtr); - - /* - * Determine the current encoding from the LC_* or LANG environment - * variables. We previously used setlocale() to determine the locale, but - * this does not work on some systems (e.g. Linux/i386 RH 5.0). - */ + CONST char *encoding = NULL; + int i, setSysEncCode = TCL_ERROR; + Tcl_Obj *pathPtr; + /* + * Determine the current encoding from the LC_* or LANG environment + * variables. We previously used setlocale() to determine the locale, + * but this does not work on some systems (e.g. Linux/i386 RH 5.0). + */ #ifdef HAVE_LANGINFO - if ( + if ( #ifdef WEAK_IMPORT_NL_LANGINFO - nl_langinfo != NULL && + nl_langinfo != NULL && #endif - setlocale(LC_CTYPE, "") != NULL) { - Tcl_DString ds; + setlocale(LC_CTYPE, "") != NULL) { + Tcl_DString ds; - /* - * Use a DString so we can modify case. - */ + /* + * Use a DString so we can overwrite it in name compatability + * checks below. + */ - Tcl_DStringInit(&ds); - encoding = Tcl_DStringAppend(&ds, nl_langinfo(CODESET), -1); - Tcl_UtfToLower(Tcl_DStringValue(&ds)); - knownEncoding = SearchKnownEncodings(encoding); - if (knownEncoding != NULL) { - Tcl_DStringAppend(bufPtr, knownEncoding, -1); - } else if (NULL != Tcl_GetEncoding(NULL, encoding)) { - Tcl_DStringAppend(bufPtr, encoding, -1); + Tcl_DStringInit(&ds); + encoding = Tcl_DStringAppend(&ds, nl_langinfo(CODESET), -1); + + Tcl_UtfToLower(Tcl_DStringValue(&ds)); +#ifdef HAVE_LANGINFO_DEBUG + fprintf(stderr, "encoding '%s'", encoding); +#endif + if (encoding[0] == 'i' && encoding[1] == 's' && encoding[2] == 'o' + && encoding[3] == '-') { + char *p, *q; + /* need to strip '-' from iso-* encoding */ + for(p = Tcl_DStringValue(&ds)+3, q = Tcl_DStringValue(&ds)+4; + *p; *p++ = *q++); + } else if (encoding[0] == 'i' && encoding[1] == 'b' + && encoding[2] == 'm' && encoding[3] >= '0' + && encoding[3] <= '9') { + char *p, *q; + /* if langinfo reports "ibm*" we should use "cp*" */ + p = Tcl_DStringValue(&ds); + *p++ = 'c'; *p++ = 'p'; + for(q = p+1; *p ; *p++ = *q++); + } else if ((*encoding == '\0') + || !strcmp(encoding, "ansi_x3.4-1968")) { + /* Use iso8859-1 for empty or 'ansi_x3.4-1968' encoding */ + encoding = "iso8859-1"; + } +#ifdef HAVE_LANGINFO_DEBUG + fprintf(stderr, " ?%s?", encoding); +#endif + setSysEncCode = Tcl_SetSystemEncoding(NULL, encoding); + if (setSysEncCode != TCL_OK) { + /* + * If this doesn't return TCL_OK, the encoding returned by + * nl_langinfo or as we translated it wasn't accepted. Do + * this fallback check. If this fails, we will enter the + * old fallback below. + */ + + for (i = 0; localeTable[i].lang != NULL; i++) { + if (strcmp(localeTable[i].lang, encoding) == 0) { + setSysEncCode = Tcl_SetSystemEncoding(NULL, + localeTable[i].encoding); + break; + } + } + } +#ifdef HAVE_LANGINFO_DEBUG + fprintf(stderr, " => '%s'\n", encoding); +#endif + Tcl_DStringFree(&ds); } - Tcl_DStringFree(&ds); - if (Tcl_DStringLength(bufPtr)) { - return Tcl_DStringValue(bufPtr); +#ifdef HAVE_LANGINFO_DEBUG + else { + fprintf(stderr, "setlocale returned NULL\n"); } - } +#endif #endif /* HAVE_LANGINFO */ - /* - * Classic fallback check. This tries a homebrew algorithm to determine - * what encoding should be used based on env vars. - */ - - encoding = getenv("LC_ALL"); + if (setSysEncCode != TCL_OK) { + /* + * Classic fallback check. This tries a homebrew algorithm to + * determine what encoding should be used based on env vars. + */ + char *langEnv = getenv("LC_ALL"); + encoding = NULL; - if (encoding == NULL || encoding[0] == '\0') { - encoding = getenv("LC_CTYPE"); - } - if (encoding == NULL || encoding[0] == '\0') { - encoding = getenv("LANG"); - } - if (encoding == NULL || encoding[0] == '\0') { - encoding = NULL; - } + if (langEnv == NULL || langEnv[0] == '\0') { + langEnv = getenv("LC_CTYPE"); + } + if (langEnv == NULL || langEnv[0] == '\0') { + langEnv = getenv("LANG"); + } + if (langEnv == NULL || langEnv[0] == '\0') { + langEnv = NULL; + } - if (encoding != NULL) { - CONST char *p; - Tcl_DString ds; + if (langEnv != NULL) { + for (i = 0; localeTable[i].lang != NULL; i++) { + if (strcmp(localeTable[i].lang, langEnv) == 0) { + encoding = localeTable[i].encoding; + break; + } + } + /* + * There was no mapping in the locale table. If there is an + * encoding subfield, we can try to guess from that. + */ + + if (encoding == NULL) { + char *p; + for (p = langEnv; *p != '\0'; p++) { + if (*p == '.') { + p++; + break; + } + } + if (*p != '\0') { + Tcl_DString ds; + Tcl_DStringInit(&ds); + encoding = Tcl_DStringAppend(&ds, p, -1); + + Tcl_UtfToLower(Tcl_DStringValue(&ds)); + setSysEncCode = Tcl_SetSystemEncoding(NULL, encoding); + if (setSysEncCode != TCL_OK) { + encoding = NULL; + } + Tcl_DStringFree(&ds); + } + } +#ifdef HAVE_LANGINFO_DEBUG + fprintf(stderr, "encoding fallback check '%s' => '%s'\n", + langEnv, encoding); +#endif + } + if (setSysEncCode != TCL_OK) { + if (encoding == NULL) { + encoding = TCL_DEFAULT_ENCODING; + } - Tcl_DStringInit(&ds); - p = encoding; - encoding = Tcl_DStringAppend(&ds, p, -1); - Tcl_UtfToLower(Tcl_DStringValue(&ds)); + Tcl_SetSystemEncoding(NULL, encoding); + } - knownEncoding = SearchKnownEncodings(encoding); - if (knownEncoding != NULL) { - Tcl_DStringAppend(bufPtr, knownEncoding, -1); - } else if (NULL != Tcl_GetEncoding(NULL, encoding)) { - Tcl_DStringAppend(bufPtr, encoding, -1); - } - if (Tcl_DStringLength(bufPtr)) { - Tcl_DStringFree(&ds); - return Tcl_DStringValue(bufPtr); + /* + * Initialize the C library's locale subsystem. This is required + * for input methods to work properly on X11. We only do this for + * LC_CTYPE because that's the necessary one, and we don't want to + * affect LC_TIME here. The side effect of setting the default + * locale should be to load any locale specific modules that are + * needed by X. [BUG: 5422 3345 4236 2522 2521]. + * In HAVE_LANGINFO, this call is already done above. + */ +#ifndef HAVE_LANGINFO + setlocale(LC_CTYPE, ""); +#endif } /* - * We didn't recognize the full value as an encoding name. If there is - * an encoding subfield, we can try to guess from that. + * In case the initial locale is not "C", ensure that the numeric + * processing is done in "C" locale regardless. This is needed because + * Tcl relies on routines like strtod, but should not have locale + * dependent behavior. */ - for (p = encoding; *p != '\0'; p++) { - if (*p == '.') { - p++; - break; - } - } - if (*p != '\0') { - knownEncoding = SearchKnownEncodings(p); - if (knownEncoding != NULL) { - Tcl_DStringAppend(bufPtr, knownEncoding, -1); - } else if (NULL != Tcl_GetEncoding(NULL, p)) { - Tcl_DStringAppend(bufPtr, p, -1); + setlocale(LC_NUMERIC, "C"); + + if ((libraryPathEncodingFixed == 0) && strcmp("identity", + Tcl_GetEncodingName(Tcl_GetEncoding(NULL, NULL))) ) { + /* + * 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 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_DStringFree(&ds); - if (Tcl_DStringLength(bufPtr)) { - return Tcl_DStringValue(bufPtr); - } + + 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"); } - return Tcl_DStringAppend(bufPtr, TCL_DEFAULT_ENCODING, -1); } /* @@ -791,9 +801,9 @@ Tcl_GetEncodingNameFromEnvironment( * * TclpSetVariables -- * - * Performs platform-specific interpreter initialization related to the - * tcl_library and tcl_platform variables, and other platform-specific - * things. + * Performs platform-specific interpreter initialization related to + * the tcl_library and tcl_platform variables, and other platform- + * specific things. * * Results: * None. @@ -806,8 +816,8 @@ Tcl_GetEncodingNameFromEnvironment( */ void -TclpSetVariables( - Tcl_Interp *interp) +TclpSetVariables(interp) + Tcl_Interp *interp; { #ifdef __CYGWIN__ SYSTEM_INFO sysInfo; @@ -817,6 +827,7 @@ TclpSetVariables( struct utsname name; #endif int unameOK; + CONST char *user; Tcl_DString ds; #ifdef HAVE_COREFOUNDATION @@ -826,7 +837,6 @@ TclpSetVariables( /* * Set msgcat fallback locale to current CFLocale identifier. */ - CFLocaleRef localeRef; if (CFLocaleCopyCurrent != NULL && CFLocaleGetIdentifier != NULL && @@ -845,74 +855,68 @@ TclpSetVariables( } CFRelease(localeRef); } -#endif /* MAC_OS_X_VERSION_MAX_ALLOWED > 1020 */ +#endif if (MacOSXGetLibraryPath(interp, MAXPATHLEN, tclLibPath) == TCL_OK) { - CONST char *str; - CFBundleRef bundleRef; - - Tcl_SetVar(interp, "tclDefaultLibrary", tclLibPath, TCL_GLOBAL_ONLY); - Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath, TCL_GLOBAL_ONLY); - Tcl_SetVar(interp, "tcl_pkgPath", " ", - TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); - - str = TclGetEnv("DYLD_FRAMEWORK_PATH", &ds); - if ((str != NULL) && (str[0] != '\0')) { - char *p = Tcl_DStringValue(&ds); - - /* - * Convert DYLD_FRAMEWORK_PATH from colon to space separated. - */ - - do { - if (*p == ':') { - *p = ' '; - } - } while (*p++); - Tcl_SetVar(interp, "tcl_pkgPath", Tcl_DStringValue(&ds), - TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); - Tcl_SetVar(interp, "tcl_pkgPath", " ", - TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); - Tcl_DStringFree(&ds); - } - bundleRef = CFBundleGetMainBundle(); - if (bundleRef) { - CFURLRef frameworksURL; - Tcl_StatBuf statBuf; - - frameworksURL = CFBundleCopyPrivateFrameworksURL(bundleRef); - if (frameworksURL) { - if (CFURLGetFileSystemRepresentation(frameworksURL, TRUE, - (unsigned char*) tclLibPath, MAXPATHLEN) && - ! TclOSstat(tclLibPath, &statBuf) && - S_ISDIR(statBuf.st_mode)) { - Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath, - TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); - Tcl_SetVar(interp, "tcl_pkgPath", " ", - TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); - } - CFRelease(frameworksURL); - } - frameworksURL = CFBundleCopySharedFrameworksURL(bundleRef); - if (frameworksURL) { - if (CFURLGetFileSystemRepresentation(frameworksURL, TRUE, - (unsigned char*) tclLibPath, MAXPATHLEN) && - ! TclOSstat(tclLibPath, &statBuf) && - S_ISDIR(statBuf.st_mode)) { - Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath, - TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); - Tcl_SetVar(interp, "tcl_pkgPath", " ", - TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); - } - CFRelease(frameworksURL); - } - } - Tcl_SetVar(interp, "tcl_pkgPath", pkgPath, - TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); + CONST char *str; + Tcl_DString ds; + CFBundleRef bundleRef; + + Tcl_SetVar(interp, "tclDefaultLibrary", tclLibPath, + TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath, + TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "tcl_pkgPath", " ", + TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); + str = TclGetEnv("DYLD_FRAMEWORK_PATH", &ds); + if ((str != NULL) && (str[0] != '\0')) { + char *p = Tcl_DStringValue(&ds); + /* convert DYLD_FRAMEWORK_PATH from colon to space separated */ + do { + if(*p == ':') *p = ' '; + } while (*p++); + Tcl_SetVar(interp, "tcl_pkgPath", Tcl_DStringValue(&ds), + TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); + Tcl_SetVar(interp, "tcl_pkgPath", " ", + TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); + Tcl_DStringFree(&ds); + } + if ((bundleRef = CFBundleGetMainBundle())) { + CFURLRef frameworksURL; + Tcl_StatBuf statBuf; + if((frameworksURL = CFBundleCopyPrivateFrameworksURL(bundleRef))) { + if(CFURLGetFileSystemRepresentation(frameworksURL, TRUE, + (unsigned char*) tclLibPath, MAXPATHLEN) && + ! TclOSstat(tclLibPath, &statBuf) && + S_ISDIR(statBuf.st_mode)) { + Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath, + TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); + Tcl_SetVar(interp, "tcl_pkgPath", " ", + TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); + } + CFRelease(frameworksURL); + } + if((frameworksURL = CFBundleCopySharedFrameworksURL(bundleRef))) { + if(CFURLGetFileSystemRepresentation(frameworksURL, TRUE, + (unsigned char*) tclLibPath, MAXPATHLEN) && + ! TclOSstat(tclLibPath, &statBuf) && + S_ISDIR(statBuf.st_mode)) { + Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath, + TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); + Tcl_SetVar(interp, "tcl_pkgPath", " ", + TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); + } + CFRelease(frameworksURL); + } + } + Tcl_SetVar(interp, "tcl_pkgPath", pkgPath, + TCL_GLOBAL_ONLY | TCL_APPEND_VALUE); } else #endif /* HAVE_COREFOUNDATION */ { - Tcl_SetVar(interp, "tcl_pkgPath", pkgPath, TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "tclDefaultLibrary", defaultLibraryDir, + TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "tcl_pkgPath", pkgPath, TCL_GLOBAL_ONLY); } #ifdef DJGPP @@ -920,7 +924,6 @@ TclpSetVariables( #else Tcl_SetVar2(interp, "tcl_platform", "platform", "unix", TCL_GLOBAL_ONLY); #endif - unameOK = 0; #ifdef __CYGWIN__ unameOK = 1; @@ -943,19 +946,19 @@ TclpSetVariables( #elif !defined NO_UNAME if (uname(&name) >= 0) { CONST char *native; - + unameOK = 1; native = Tcl_ExternalToUtfDString(NULL, name.sysname, -1, &ds); Tcl_SetVar2(interp, "tcl_platform", "os", native, TCL_GLOBAL_ONLY); Tcl_DStringFree(&ds); - + /* - * The following code is a special hack to handle differences in the - * way version information is returned by uname. On most systems the - * full version number is available in name.release. However, under - * AIX the major version number is in name.version and the minor - * version number is in name.release. + * The following code is a special hack to handle differences in + * the way version information is returned by uname. On most + * systems the full version number is available in name.release. + * However, under AIX the major version number is in + * name.version and the minor version number is in name.release. */ if ((strchr(name.release, '.') != NULL) @@ -963,33 +966,17 @@ TclpSetVariables( Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.release, TCL_GLOBAL_ONLY); } else { -#ifdef DJGPP - /* - * For some obscure reason DJGPP puts major version into - * name.release and minor into name.version. As of DJGPP 2.04 this - * is documented in djgpp libc.info file. - */ - - Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.release, - TCL_GLOBAL_ONLY); - Tcl_SetVar2(interp, "tcl_platform", "osVersion", ".", - TCL_GLOBAL_ONLY|TCL_APPEND_VALUE); - Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.version, - TCL_GLOBAL_ONLY|TCL_APPEND_VALUE); -#else Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.version, TCL_GLOBAL_ONLY); Tcl_SetVar2(interp, "tcl_platform", "osVersion", ".", TCL_GLOBAL_ONLY|TCL_APPEND_VALUE); Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.release, TCL_GLOBAL_ONLY|TCL_APPEND_VALUE); - -#endif /* DJGPP */ } Tcl_SetVar2(interp, "tcl_platform", "machine", name.machine, TCL_GLOBAL_ONLY); } -#endif /* !NO_UNAME */ +#endif if (!unameOK) { Tcl_SetVar2(interp, "tcl_platform", "os", "", TCL_GLOBAL_ONLY); Tcl_SetVar2(interp, "tcl_platform", "osVersion", "", TCL_GLOBAL_ONLY); @@ -997,24 +984,20 @@ TclpSetVariables( } /* - * Copy the username of the real user (according to getuid()) into - * tcl_platform(user). + * Copy USER or LOGNAME environment variable into tcl_platform(user) */ - { - struct passwd *pwEnt = TclpGetPwUid(getuid()); - const char *user; - - if (pwEnt == NULL) { + Tcl_DStringInit(&ds); + user = TclGetEnv("USER", &ds); + if (user == NULL) { + user = TclGetEnv("LOGNAME", &ds); + if (user == NULL) { user = ""; - Tcl_DStringInit(&ds); /* ensure cleanliness */ - } else { - user = Tcl_ExternalToUtfDString(NULL, pwEnt->pw_name, -1, &ds); } - - Tcl_SetVar2(interp, "tcl_platform", "user", user, TCL_GLOBAL_ONLY); - Tcl_DStringFree(&ds); } + Tcl_SetVar2(interp, "tcl_platform", "user", user, TCL_GLOBAL_ONLY); + Tcl_DStringFree(&ds); + } /* @@ -1022,14 +1005,15 @@ TclpSetVariables( * * TclpFindVariable -- * - * Locate the entry in environ for a given name. On Unix this routine is - * case sensetive, on Windows this matches mixed case. + * Locate the entry in environ for a given name. On Unix this + * routine is case sensetive, 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). + * 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. @@ -1038,10 +1022,10 @@ TclpSetVariables( */ int -TclpFindVariable( - CONST char *name, /* Name of desired environment variable +TclpFindVariable(name, lengthPtr) + CONST char *name; /* Name of desired environment variable * (native). */ - int *lengthPtr) /* Used to return length of name (for + int *lengthPtr; /* Used to return length of name (for * successful searches) or number of non-NULL * entries in environ (for unsuccessful * searches). */ @@ -1063,231 +1047,155 @@ TclpFindVariable( result = i; goto done; } - + Tcl_DStringFree(&envString); } - + *lengthPtr = i; - done: + done: Tcl_DStringFree(&envString); return result; } -#ifndef TCL_NO_STACK_CHECK /* *---------------------------------------------------------------------- * - * TclpGetCStackParams -- + * Tcl_Init -- * - * Determine the stack params for the current thread: in which - * direction does the stack grow, and what is the stack lower (resp. - * upper) bound for safe invocation of a new command? This is used to - * cache the values needed for an efficient computation of - * TclpCheckStackSpace() when the interp is known. + * This procedure is typically invoked by Tcl_AppInit procedures + * to find and source the "init.tcl" script, which should exist + * somewhere on the Tcl library path. * * Results: - * Returns 1 if the stack grows down, in which case a stack lower bound - * is stored at stackBoundPtr. If the stack grows up, 0 is returned and - * an upper bound is stored at stackBoundPtr. If a bound cannot be - * determined NULL is stored at stackBoundPtr. + * 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 -TclpGetCStackParams( - int **stackBoundPtr) +Tcl_Init(interp) + Tcl_Interp *interp; /* Interpreter to initialize. */ { - int result = TCL_OK; - size_t stackSize = 0; /* The size of the current stack. */ - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - /* Most variables are actually in a - * thread-specific data block to minimise the - * impact on the stack. */ -#ifdef TCL_CROSS_COMPILE - if (stackGrowsDown == -1) { - /* - * Not initialised! - */ + Tcl_Obj *pathPtr; - stackGrowsDown = StackGrowsDown(&result); + if (tclPreInitScript != NULL) { + if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) { + return (TCL_ERROR); + }; } -#endif - /* - * The first time through in a thread: record the "outermost" stack - * frame and inquire with the OS about the stack size. - */ - - if (tsdPtr->outerVarPtr == NULL) { - tsdPtr->outerVarPtr = &result; - result = GetStackSize(&stackSize); - if (result != TCL_OK) { - /* Can't check, assume it always succeeds */ -#ifdef TCL_CROSS_COMPILE - stackGrowsDown = 1; -#endif - tsdPtr->stackBound = NULL; - goto done; - } + pathPtr = TclGetLibraryPath(); + if (pathPtr == NULL) { + pathPtr = Tcl_NewObj(); } + Tcl_IncrRefCount(pathPtr); + Tcl_SetVar2Ex(interp, "tcl_libPath", NULL, pathPtr, TCL_GLOBAL_ONLY); + Tcl_DecrRefCount(pathPtr); + return Tcl_Eval(interp, initScript); +} + +/* + *---------------------------------------------------------------------- + * + * 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. + * + *---------------------------------------------------------------------- + */ - if (stackSize || (tsdPtr->stackBound && - ((stackGrowsDown && (&result < tsdPtr->stackBound)) || - (!stackGrowsDown && (&result > tsdPtr->stackBound))))) { - /* - * Either the thread's first pass or stack failure: set the params - */ +void +Tcl_SourceRCFile(interp) + Tcl_Interp *interp; /* Interpreter to source rc file into. */ +{ + Tcl_DString temp; + CONST char *fileName; + Tcl_Channel errChannel; + + fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY); + + if (fileName != NULL) { + Tcl_Channel c; + CONST char *fullName; - if (!stackSize) { + Tcl_DStringInit(&temp); + fullName = Tcl_TranslateFileName(interp, fileName, &temp); + if (fullName == NULL) { /* - * Stack failure: if we didn't already blow up, we are within the - * safety area. Recheck with the OS in case the stack was grown. + * Couldn't translate the file name (e.g. it referred to a + * bogus user or there was no HOME environment variable). + * Just do nothing. */ - result = GetStackSize(&stackSize); - if (result != TCL_OK) { - /* Can't check, assume it always succeeds */ -#ifdef TCL_CROSS_COMPILE - stackGrowsDown = 1; -#endif - tsdPtr->stackBound = NULL; - goto done; - } - } - - if (stackGrowsDown) { - tsdPtr->stackBound = (int *) ((char *)tsdPtr->outerVarPtr - - stackSize); - if (tsdPtr->stackBound > tsdPtr->outerVarPtr) { - /* Overflow, that should never happen, just set it to NULL. - * See [Bug #3166410] */ - tsdPtr->stackBound = NULL; - } } else { - tsdPtr->stackBound = (int *) ((char *)tsdPtr->outerVarPtr + - stackSize); - if (tsdPtr->stackBound < tsdPtr->outerVarPtr) { - /* Overflow, that should never happen, just set it to NULL. - * See [Bug #3166410] */ - tsdPtr->stackBound = NULL; + + /* + * 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); } - - done: - *stackBoundPtr = tsdPtr->stackBound; - return stackGrowsDown; -} - -#ifdef TCL_CROSS_COMPILE -int -StackGrowsDown( - int *parent) -{ - int here; - return (&here < parent); } -#endif /* *---------------------------------------------------------------------- * - * GetStackSize -- + * TclpCheckStackSpace -- * - * Discover what the stack size for the current thread/process actually - * is. Expects to only ever be called once per thread and then only at a - * point when there is a reasonable amount of space left on the current - * stack; TclpCheckStackSpace is called sufficiently frequently that that - * is true. + * Detect if we are about to blow the stack. Called before an + * evaluation can happen when nesting depth is checked. * * Results: - * TCL_OK if the stack space was discovered, TCL_BREAK if the stack space - * was undiscoverable in a way that stack checks should fail, and - * TCL_CONTINUE if the stack space was undiscoverable in a way that stack - * checks should succeed. + * 1 if there is enough stack space to continue; 0 if not. * * Side effects: - * None + * None. * *---------------------------------------------------------------------- */ -static int -GetStackSize( - size_t *stackSizePtr) +int +TclpCheckStackSpace() { - size_t rawStackSize; - struct rlimit rLimit; /* The result from getrlimit(). */ - -#ifdef TCL_THREADS - rawStackSize = TclpThreadGetStackSize(); - if (rawStackSize == (size_t) -1) { - /* - * Some kind of confirmed error in TclpThreadGetStackSize?! Fall back - * to whatever getrlimit can determine. - */ - STACK_DEBUG(("stack checks: TclpThreadGetStackSize failed in \n")); - } - if (rawStackSize > 0) { - goto finalSanityCheck; - } - /* - * If we have zero or an error, try the system limits instead. After all, - * the pthread documentation states that threads should always be bound by - * the system stack size limit in any case. + * This function is unimplemented on Unix platforms. */ -#endif /* TCL_THREADS */ - if (getrlimit(RLIMIT_STACK, &rLimit) != 0) { - /* - * getrlimit() failed, just fail the whole thing. - */ - STACK_DEBUG(("skipping stack checks with failure: getrlimit failed\n")); - return TCL_BREAK; - } - if (rLimit.rlim_cur == RLIM_INFINITY) { - /* - * Limit is "infinite"; there is no stack limit. - */ - STACK_DEBUG(("skipping stack checks with success: infinite limit\n")); - return TCL_CONTINUE; - } - rawStackSize = rLimit.rlim_cur; - - /* - * Final sanity check on the determined stack size. If we fail this, - * assume there are bogus values about and that we can't actually figure - * out what the stack size really is. - */ - -#ifdef TCL_THREADS /* Stop warning... */ - finalSanityCheck: -#endif - if (rawStackSize <= 0) { - STACK_DEBUG(("skipping stack checks with success\n")); - return TCL_CONTINUE; - } - - /* - * Calculate a stack size with a safety margin. - */ - - *stackSizePtr = (rawStackSize / TCL_MAGIC_STACK_DIVISOR) - - (getpagesize() * TCL_RESERVED_STACK_PAGES); - - return TCL_OK; + return 1; } -#endif /* TCL_NO_STACK_CHECK */ /* *---------------------------------------------------------------------- * * MacOSXGetLibraryPath -- * - * If we have a bundle structure for the Tcl installation, then check - * there first to see if we can find the libraries there. + * If we have a bundle structure for the Tcl installation, + * then check there first to see if we can find the libraries + * there. * * Results: * TCL_OK if we have found the tcl library; TCL_ERROR otherwise. @@ -1300,27 +1208,13 @@ GetStackSize( #ifdef HAVE_COREFOUNDATION static int -MacOSXGetLibraryPath( - Tcl_Interp *interp, - int maxPathLen, - char *tclLibPath) +MacOSXGetLibraryPath(Tcl_Interp *interp, int maxPathLen, char *tclLibPath) { int foundInFramework = TCL_ERROR; - #ifdef TCL_FRAMEWORK - foundInFramework = Tcl_MacOSXOpenVersionedBundleResources(interp, - "com.tcltk.tcllibrary", TCL_FRAMEWORK_VERSION, 0, maxPathLen, - tclLibPath); + foundInFramework = Tcl_MacOSXOpenVersionedBundleResources(interp, + "com.tcltk.tcllibrary", TCL_FRAMEWORK_VERSION, 0, maxPathLen, tclLibPath); #endif - return foundInFramework; } #endif /* HAVE_COREFOUNDATION */ - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ |