summaryrefslogtreecommitdiffstats
path: root/generic/tclInterp.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclInterp.c')
-rw-r--r--generic/tclInterp.c277
1 files changed, 172 insertions, 105 deletions
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index 194944b..d1cd7f5 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -10,116 +10,13 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInterp.c,v 1.52 2004/11/22 21:24:30 dgp Exp $
+ * RCS: @(#) $Id: tclInterp.c,v 1.53 2004/11/30 19:34:49 dgp Exp $
*/
#include "tclInt.h"
#include <stdio.h>
/*
- * In order to find init.tcl during initialization, the following script
- * is invoked by Tcl_Init(). It looks in several different directories:
- *
- * $tcl_library - can specify a primary location, if set,
- * no other locations will be checked. This
- * is the recommended way for a program that
- * embeds Tcl to specifically tell Tcl where
- * to find an init.tcl file.
- *
- * $env(TCL_LIBRARY) - highest priority so user can always override
- * the search path unless the application has
- * specified an exact directory above
- *
- * $tclDefaultLibrary - INTERNAL: This variable is set by Tcl
- * on those platforms where it can determine
- * at runtime the directory where it expects
- * the init.tcl file to be. After [tclInit]
- * reads and uses this value, it [unset]s it.
- * External users of Tcl should not make use
- * of the variable to customize [tclInit].
- *
- * $tcl_libPath - OBSOLETE: This variable is no longer
- * set by Tcl itself, but [tclInit] examines
- * it in case some program that embeds Tcl
- * is customizing [tclInit] by setting this
- * variable to a list of directories in which
- * to search.
- *
- * [tcl::pkgconfig get scriptdir,runtime]
- * - the directory determined by configure to
- * be the place where Tcl's script library
- * is to be installed.
- *
- * The first directory on this path that contains a valid init.tcl script
- * will be set as the value of tcl_library.
- *
- * Note that this entire search mechanism can be bypassed by defining an
- * alternate tclInit procedure before calling Tcl_Init().
- */
-
-static char initScript[] = "if {[info proc tclInit]==\"\"} {\n\
- proc tclInit {} {\n\
- global tcl_libPath tcl_library\n\
- global env tclDefaultLibrary\n\
- variable ::tcl::LibPath\n\
- rename tclInit {}\n\
- set errors {}\n\
- set LibPath {}\n\
- if {[info exists tcl_library]} {\n\
- lappend LibPath $tcl_library\n\
- } else {\n\
- if {[info exists env(TCL_LIBRARY)]} {\n\
- lappend LibPath $env(TCL_LIBRARY)\n\
- if {[regexp ^tcl(.*)$ [file tail $env(TCL_LIBRARY)] -> tail]} {\n\
- if {$tail ne [info tclversion]} {\n\
- lappend LibPath [file join [file dirname\\\n\
- $env(TCL_LIBRARY)] tcl[info tclversion]]\n\
- }\n\
- }\n\
- }\n\
- if {[catch {\n\
- lappend LibPath $tclDefaultLibrary\n\
- unset tclDefaultLibrary\n\
- }]} {\n\
- lappend LibPath [::tcl::pkgconfig get scriptdir,runtime]\n\
- }\n\
- set parentDir [file normalize [file dirname [file dirname\\\n\
- [info nameofexecutable]]]]\n\
- set grandParentDir [file dirname $parentDir]\n\
- lappend LibPath [file join $parentDir lib tcl[info tclversion]]\n\
- lappend LibPath [file join $grandParentDir lib tcl[info tclversion]]\n\
- lappend LibPath [file join $parentDir library]\n\
- lappend LibPath [file join $grandParentDir library]\n\
- lappend LibPath [file join $grandParentDir\\\n\
- tcl[info patchlevel] library]\n\
- lappend LibPath [file join [file dirname $grandParentDir]\\\n\
- tcl[info patchlevel] library]\n\
- catch {\n\
- set LibPath [concat $LibPath $tcl_libPath]\n\
- }\n\
- }\n\
- foreach i $LibPath {\n\
- set tcl_library $i\n\
- set tclfile [file join $i init.tcl]\n\
- if {[file exists $tclfile]} {\n\
- if {![catch {uplevel #0 [list source $tclfile]} msg opts]} {\n\
- return\n\
- } else {\n\
- append errors \"$tclfile: $msg\n\"\n\
- append errors \"[dict get $opts -errorinfo]\n\"\n\
- }\n\
- }\n\
- }\n\
- set msg \"Can't find a usable init.tcl in the following directories: \n\"\n\
- append msg \" $LibPath\n\n\"\n\
- append msg \"$errors\n\n\"\n\
- append msg \"This probably means that Tcl wasn't installed properly.\n\"\n\
- error $msg\n\
- }\n\
-}\n\
-tclInit";
-
-/*
* A pointer to a string that holds an initialization script that if non-NULL
* is evaluated in Tcl_Init() prior to the built-in initialization script
* above. This variable can be modified by the procedure below.
@@ -404,12 +301,182 @@ int
Tcl_Init(interp)
Tcl_Interp *interp; /* Interpreter to initialize. */
{
+ int code;
+ Tcl_DString script, encodingName;
+ Tcl_Obj *path;
+
if (tclPreInitScript != NULL) {
if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) {
return (TCL_ERROR);
};
}
- return Tcl_Eval(interp, initScript);
+/*
+ * In order to find init.tcl during initialization, the following script
+ * is invoked by Tcl_Init(). It looks in several different directories:
+ *
+ * $tcl_library - can specify a primary location, if set,
+ * no other locations will be checked. This
+ * is the recommended way for a program that
+ * embeds Tcl to specifically tell Tcl where
+ * to find an init.tcl file.
+ *
+ * $env(TCL_LIBRARY) - highest priority so user can always override
+ * the search path unless the application has
+ * specified an exact directory above
+ *
+ * $tclDefaultLibrary - INTERNAL: This variable is set by Tcl
+ * on those platforms where it can determine
+ * at runtime the directory where it expects
+ * the init.tcl file to be. After [tclInit]
+ * reads and uses this value, it [unset]s it.
+ * External users of Tcl should not make use
+ * of the variable to customize [tclInit].
+ *
+ * $tcl_libPath - OBSOLETE: This variable is no longer
+ * set by Tcl itself, but [tclInit] examines
+ * it in case some program that embeds Tcl
+ * is customizing [tclInit] by setting this
+ * variable to a list of directories in which
+ * to search.
+ *
+ * [tcl::pkgconfig get scriptdir,runtime]
+ * - the directory determined by configure to
+ * be the place where Tcl's script library
+ * is to be installed.
+ *
+ * The first directory on this path that contains a valid init.tcl script
+ * will be set as the value of tcl_library.
+ *
+ * Note that this entire search mechanism can be bypassed by defining an
+ * alternate tclInit procedure before calling Tcl_Init().
+ */
+ code = Tcl_Eval(interp,
+"if {[info proc tclInit]==\"\"} {\n"
+" proc tclInit {} {\n"
+" global tcl_libPath tcl_library\n"
+" global env tclDefaultLibrary\n"
+" variable ::tcl::LibPath\n"
+" rename tclInit {}\n"
+" set errors {}\n"
+" set localPath {}\n"
+" set LibPath {}\n"
+" if {[info exists tcl_library]} {\n"
+" lappend localPath $tcl_library\n"
+" } else {\n"
+" if {[info exists env(TCL_LIBRARY)]\n"
+" && [string length $env(TCL_LIBRARY)]} {\n"
+" lappend localPath $env(TCL_LIBRARY)\n"
+" lappend LibPath $env(TCL_LIBRARY)\n"
+" if {[regexp ^tcl(.*)$ [file tail $env(TCL_LIBRARY)] -> tail]} {\n"
+" if {$tail ne [info tclversion]} {\n"
+" lappend localPath [file join [file dirname\\\n"
+" $env(TCL_LIBRARY)] tcl[info tclversion]]\n"
+" lappend LibPath [file join [file dirname\\\n"
+" $env(TCL_LIBRARY)] tcl[info tclversion]]\n"
+" }\n"
+" }\n"
+" }\n"
+" if {[catch {\n"
+" lappend localPath $tclDefaultLibrary\n"
+" unset tclDefaultLibrary\n"
+" }]} {\n"
+" lappend localPath [::tcl::pkgconfig get scriptdir,runtime]\n"
+" }\n"
+" set parentDir [file normalize [file dirname [file dirname\\\n"
+" [info nameofexecutable]]]]\n"
+" set grandParentDir [file dirname $parentDir]\n"
+" lappend LibPath [file join $parentDir lib tcl[info tclversion]]\n"
+" lappend LibPath [file join $grandParentDir lib tcl[info tclversion]]\n"
+" lappend LibPath [file join $parentDir library]\n"
+" lappend LibPath [file join $grandParentDir library]\n"
+" lappend LibPath [file join $grandParentDir\\\n"
+" tcl[info patchlevel] library]\n"
+" lappend LibPath [file join [file dirname $grandParentDir]\\\n"
+" tcl[info patchlevel] library]\n"
+" catch {\n"
+" set LibPath [concat $LibPath $tcl_libPath]\n"
+" }\n"
+" }\n"
+" foreach i [concat $localPath $LibPath] {\n"
+" set tcl_library $i\n"
+" set tclfile [file join $i init.tcl]\n"
+" if {[file exists $tclfile]} {\n"
+" if {![catch {uplevel #0 [list source $tclfile]} msg opts]} {\n"
+" return\n"
+" } else {\n"
+" append errors \"$tclfile: $msg\n\"\n"
+" append errors \"[dict get $opts -errorinfo]\n\"\n"
+" }\n"
+" }\n"
+" }\n"
+" set msg \"Can't find a usable init.tcl in the following directories: \n\"\n"
+" append msg \" $localPath $LibPath\n\n\"\n"
+" append msg \"$errors\n\n\"\n"
+" append msg \"This probably means that Tcl wasn't installed properly.\n\"\n"
+" error $msg\n"
+" }\n"
+"}\n"
+"tclInit");
+
+ if (code != TCL_OK) {
+ return code;
+ }
+
+ /*
+ * Now that [info library] is initialized, make sure that
+ * [file join [info library] encoding] is on the encoding
+ * search path.
+ *
+ * Relying on use of original built-in commands.
+ * Should be a safe assumption during interp initialization.
+ * More robust would be to use C-coded equivalents, but that's such
+ * a pain...
+ */
+
+ Tcl_DStringInit(&script);
+ Tcl_DStringAppend(&script, "lsearch -exact", -1);
+ path = Tcl_DuplicateObj(TclGetEncodingSearchPath());
+ Tcl_IncrRefCount(path);
+ Tcl_DStringAppendElement(&script, Tcl_GetString(path));
+ Tcl_DStringAppend(&script, " [file join [info library] encoding]", -1);
+ code = Tcl_EvalEx(interp, Tcl_DStringValue(&script),
+ Tcl_DStringLength(&script), TCL_EVAL_GLOBAL);
+ Tcl_DStringFree(&script);
+ if (code == TCL_OK) {
+ int index;
+ Tcl_GetIntFromObj(interp, Tcl_GetObjResult(interp), &index);
+ if (index != -1) {
+ /* [info library]/encoding already on the encoding search path */
+ goto done;
+ }
+ }
+ Tcl_DStringInit(&script);
+ Tcl_DStringAppend(&script, "file join [info library] encoding", -1);
+ code = Tcl_EvalEx(interp, Tcl_DStringValue(&script),
+ Tcl_DStringLength(&script), TCL_EVAL_GLOBAL);
+ Tcl_DStringFree(&script);
+ if (code == TCL_OK) {
+ Tcl_ListObjAppendElement(NULL, path, Tcl_GetObjResult(interp));
+ TclSetEncodingSearchPath(path);
+ }
+done:
+ /*
+ * Now that we know the distributed *.enc files are on the encoding
+ * search path, check whether the [encoding system] matches that
+ * specified by the environment, and if not, attempt to correct it
+ */
+ TclpGetEncodingNameFromEnvironment(&encodingName);
+ if (strcmp(Tcl_DStringValue(&encodingName), Tcl_GetEncodingName(NULL))) {
+ code = Tcl_SetSystemEncoding(NULL, Tcl_DStringValue(&encodingName));
+ if (code == TCL_ERROR) {
+ Tcl_Panic("system encoding \"", Tcl_DStringValue(&encodingName),
+ "\" not available");
+ }
+ }
+ Tcl_DStringFree(&encodingName);
+ Tcl_DecrRefCount(path);
+ Tcl_ResetResult(interp);
+ return TCL_OK;
}
/*