diff options
Diffstat (limited to 'generic/tclInterp.c')
| -rw-r--r-- | generic/tclInterp.c | 277 |
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; } /* |