From 556e3e1101cc8390dab71ef3c26d9370fc9809d5 Mon Sep 17 00:00:00 2001 From: Pat Thoyts Date: Fri, 26 Sep 2008 20:18:37 +0000 Subject: [PATCH] Merged in mods from ActiveState's basekit code to properly support initialization when built as a shared library. Note that TclKit_SetKitPath should be passed a utf-8 path to ensure the dll can be opened on non-ascii/unicode systems. Extended to set of encodings to match the basekit set which supports many more locales without adding excessive size. Only the asian locales are missing now from the default build. git-svn-id: svn://svn.equi4.com/kitgen/trunk@4442 9e558909-932a-0410-a563-af77432da1eb --- files/boot.tcl | 231 +++++++++++++++++++++++++------------------------ kitInit.c | 137 ++++++++++++++++------------- setupvfs.tcl | 41 +++++---- 3 files changed, 214 insertions(+), 195 deletions(-) diff --git a/files/boot.tcl b/files/boot.tcl index d00e65d..8d19fce 100644 --- a/files/boot.tcl +++ b/files/boot.tcl @@ -1,121 +1,124 @@ proc tclInit {} { - rename tclInit {} - - global auto_path tcl_library tcl_libPath tcl_version tclkit_system_encoding - - set noe [info nameofexecutable] - - set tcl_library [file join $noe lib tcl$tcl_version] - set tcl_libPath [list $tcl_library [file join $noe lib]] - - # get rid of a build residue - unset -nocomplain ::tclDefaultLibrary - - # The following code only gets executed if we don't have our exe - # already mounted. This should only happen once per thread. - # We could use [vfs::filesystem info], but that would require - # loading vfs into every interp. - if {![file isdirectory $noe]} { - load {} vfs - - # lookup and emulate "source" of lib/vfs1*/{vfs*.tcl,mk4vfs.tcl} - if {[llength [info command mk::file]]} { - set driver mk4 - - # must use raw Metakit calls because VFS is not yet in place - set d [mk::select exe.dirs parent 0 name lib] - set d [mk::select exe.dirs parent $d -glob name vfs1*] - - foreach x {vfsUtils vfslib mk4vfs} { - set n [mk::select exe.dirs!$d.files name $x.tcl] - if {[llength $n] != 1} { error "$x: cannot find startup script"} - - set s [mk::get exe.dirs!$d.files!$n contents] - catch {set s [zlib decompress $s]} - uplevel #0 $s - } - - # use on-the-fly decompression, if mk4vfs understands that - set mk4vfs::zstreamed 1 - } else { - set driver mkcl - - # use raw Vlerq calls if Mk4tcl is not available - # $::vlerq::starkit_root is set in the init script in kitInit.c - set rootv [vlerq get $::vlerq::starkit_root 0 dirs] - set dname [vlerq get $rootv * name] - set prows [vlerq get $rootv * parent] - foreach r [lsearch -int -all $prows 0] { - if {[lindex $dname $r] eq "lib"} break - } - - # glob for a subdir in "lib", then source the specified file inside it - foreach {d f} { - vfs1* vfsUtils.tcl vfs1* vfslib.tcl vqtcl4* mkclvfs.tcl - } { - foreach z [lsearch -int -all $prows $r] { - if {[string match $d [lindex $dname $z]]} break - } + rename tclInit {} - set files [vlerq get $rootv $z files] - set names [vlerq get $files * name] - - set n [lsearch $names $f] - if {$n < 0} { error "$d/$f: cannot find startup script"} - - set s [vlerq get $files $n contents] - catch {set s [zlib decompress $s]} - uplevel #0 $s - } - - # hack the mkcl info so it will know this mount point as "exe" - set vfs::mkcl::v::rootv(exe) $rootv - set vfs::mkcl::v::dname(exe) $dname - set vfs::mkcl::v::prows(exe) $prows - } + global auto_path tcl_library tcl_libPath tcl_version tclkit_system_encoding - # mount the executable, i.e. make all runtime files available - vfs::filesystem mount $noe [list ::vfs::${driver}::handler exe] + # find the file to mount. + set noe $::tcl::kitpath + # resolve symlinks + set noe [file dirname [file normalize [file join $noe __dummy__]]] + set tcl_library [file join $noe lib tcl$tcl_version] + set tcl_libPath [list $tcl_library [file join $noe lib]] - # alter path to find encodings - if {[info tclversion] eq "8.4"} { - load {} pwb - librarypath [info library] - } else { - encoding dirs [list [file join [info library] encoding]] ;# TIP 258 - } - # if the C code passed us a system encoding, apply it here. - if {[info exists tclkit_system_encoding]} { - # It is possible the chosen encoding is unavailable in which case - # we will be left with 'identity' to be handled below. - catch {encoding system $tclkit_system_encoding} - unset tclkit_system_encoding - } - # fix system encoding, if it wasn't properly set up (200207.004 bug) - if {[encoding system] eq "identity"} { - switch $::tcl_platform(platform) { - windows { encoding system cp1252 } - macintosh { encoding system macRoman } - default { encoding system iso8859-1 } - } - } + # get rid of a build residue + unset -nocomplain ::tclDefaultLibrary + + # The following code only gets executed if we don't have our exe + # already mounted. This should only happen once per thread. + # We could use [vfs::filesystem info], but that would require + # loading vfs into every interp. + if {![file isdirectory $noe]} { + load {} vfs + + # lookup and emulate "source" of lib/vfs1*/{vfs*.tcl,mk4vfs.tcl} + if {[llength [info command mk::file]]} { + set driver mk4 + + # must use raw Metakit calls because VFS is not yet in place + set d [mk::select exe.dirs parent 0 name lib] + set d [mk::select exe.dirs parent $d -glob name vfs1*] + + foreach x {vfsUtils vfslib mk4vfs} { + set n [mk::select exe.dirs!$d.files name $x.tcl] + if {[llength $n] != 1} { error "$x: cannot find startup script"} + + set s [mk::get exe.dirs!$d.files!$n contents] + catch {set s [zlib decompress $s]} + uplevel #0 $s + } + + # use on-the-fly decompression, if mk4vfs understands that + set mk4vfs::zstreamed 1 + } else { + set driver mkcl + + # use raw Vlerq calls if Mk4tcl is not available + # $::vlerq::starkit_root is set in the init script in kitInit.c + set rootv [vlerq get $::vlerq::starkit_root 0 dirs] + set dname [vlerq get $rootv * name] + set prows [vlerq get $rootv * parent] + foreach r [lsearch -int -all $prows 0] { + if {[lindex $dname $r] eq "lib"} break + } + + # glob for a subdir in "lib", then source the specified file inside it + foreach {d f} { + vfs1* vfsUtils.tcl vfs1* vfslib.tcl vqtcl4* mkclvfs.tcl + } { + foreach z [lsearch -int -all $prows $r] { + if {[string match $d [lindex $dname $z]]} break + } + + set files [vlerq get $rootv $z files] + set names [vlerq get $files * name] + + set n [lsearch $names $f] + if {$n < 0} { error "$d/$f: cannot find startup script"} + + set s [vlerq get $files $n contents] + catch {set s [zlib decompress $s]} + uplevel #0 $s + } + + # hack the mkcl info so it will know this mount point as "exe" + set vfs::mkcl::v::rootv(exe) $rootv + set vfs::mkcl::v::dname(exe) $dname + set vfs::mkcl::v::prows(exe) $prows + } - # now remount the executable with the correct encoding - #vfs::filesystem unmount $noe - vfs::filesystem unmount [lindex [::vfs::filesystem info] 0] + # mount the executable, i.e. make all runtime files available + vfs::filesystem mount $noe [list ::vfs::${driver}::handler exe] - set noe [info nameofexecutable] - set tcl_library [file join $noe lib tcl$tcl_version] - set tcl_libPath [list $tcl_library [file join $noe lib]] - vfs::filesystem mount $noe [list ::vfs::${driver}::handler exe] - } - - # load config settings file if present - namespace eval ::vfs { variable tclkit_version 1 } - catch { uplevel #0 [list source [file join $noe config.tcl]] } - - uplevel #0 [list source [file join $tcl_library init.tcl]] - - # reset auto_path, so that init.tcl's search outside of tclkit is cancelled - set auto_path $tcl_libPath + # alter path to find encodings + if {[info tclversion] eq "8.4"} { + load {} pwb + librarypath [info library] + } else { + encoding dirs [list [file join [info library] encoding]] ;# TIP 258 + } + # if the C code passed us a system encoding, apply it here. + if {[info exists tclkit_system_encoding]} { + # It is possible the chosen encoding is unavailable in which case + # we will be left with 'identity' to be handled below. + catch {encoding system $tclkit_system_encoding} + unset tclkit_system_encoding + } + # fix system encoding, if it wasn't properly set up (200207.004 bug) + if {[encoding system] eq "identity"} { + switch $::tcl_platform(platform) { + windows { encoding system cp1252 } + macintosh { encoding system macRoman } + default { encoding system iso8859-1 } + } + } + + # now remount the executable with the correct encoding + vfs::filesystem unmount $noe + set noe $::tcl::kitpath + # resolve symlinks + set noe [file dirname [file normalize [file join $noe __dummy__]]] + + set tcl_library [file join $noe lib tcl$tcl_version] + set tcl_libPath [list $tcl_library [file join $noe lib]] + vfs::filesystem mount $noe [list ::vfs::${driver}::handler exe] + } + + # load config settings file if present + namespace eval ::vfs { variable tclkit_version 1 } + catch { uplevel #0 [list source [file join $noe config.tcl]] } + + uplevel #0 [list source [file join $tcl_library init.tcl]] + + # reset auto_path, so that init.tcl's search outside of tclkit is cancelled + set auto_path $tcl_libPath } diff --git a/kitInit.c b/kitInit.c index 97d2c3a..5542945 100644 --- a/kitInit.c +++ b/kitInit.c @@ -9,6 +9,7 @@ * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 2000-2006 Jean-Claude Wippler * Copyright (c) 2003-2006 ActiveState Software Inc. + * Copyright (c) 2007-2008 Pat Thoyts * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -48,9 +49,11 @@ Tcl_AppInitProc Thread_Init; Tcl_AppInitProc Itcl_Init; #endif #ifdef _WIN32 -Tcl_AppInitProc Dde_Init, Registry_Init; +Tcl_AppInitProc Dde_Init, Dde_SafeInit, Registry_Init; #endif +static Tcl_AppInitProc TclKitPath_Init; + /* insert custom prototypes here */ #ifdef WIN32 @@ -74,14 +77,13 @@ static void TclKit_InitStdChannels(void); static char appInitCmd[] = "proc tclKitInit {} {\n" "rename tclKitInit {}\n" + "load {} tclkitpath\n" + /*"puts \"appInit: [encoding system] $::tcl::kitpath\"\n"*/ "catch {load {} zlib}\n" - "if {![info exists ::tcl::basekit]} {\n" - "namespace eval ::tcl { variable basekit [info nameofexecutable] }\n" - "}\n" #ifdef KIT_LITE "load {} vlerq\n" "namespace eval ::vlerq {}\n" - "if {[catch { vlerq open $::tcl::basekit } ::vlerq::starkit_root]} {\n" + "if {[catch { vlerq open $::tcl::kitpath } ::vlerq::starkit_root]} {\n" "set n -1\n" "} else {\n" "set files [vlerq get $::vlerq::starkit_root 0 dirs 0 files]\n" @@ -91,7 +93,7 @@ static char appInitCmd[] = "array set a [vlerq get $files $n]\n" #else "load {} Mk4tcl\n" - "mk::file open exe $::tcl::basekit -readonly\n" + "mk::file open exe $::tcl::kitpath -readonly\n" "set n [mk::select exe.dirs!0.files name boot.tcl]\n" "if {[llength $n] == 1} {\n" "array set a [mk::get exe.dirs!0.files!$n]\n" @@ -106,7 +108,7 @@ static char appInitCmd[] = "uplevel #0 { source [lindex $::argv 1] }\n" "exit\n" "} else {\n" - "error \"\n $::tcl::basekit has no VFS data to start up\"\n" + "error \"\n $::tcl::kitpath has no VFS data to start up\"\n" "}\n" "}\n" "tclKitInit" @@ -117,7 +119,8 @@ static char preInitCmd[] = "rename tclKitPreInit {}\n" /* In 8.5 we need to set these paths for child interps */ "global tcl_library tcl_libPath tcl_version\n" - "set noe [info nameofexecutable]\n" + "load {} tclkitpath\n" + "set noe $::tcl::kitpath\n" "set tcl_library [file join $noe lib tcl$tcl_version]\n" "set tcl_libPath [list $tcl_library [file join $noe lib]]\n" "set tcl_pkgPath [list $tcl_library [file join $noe lib]]\n" @@ -126,12 +129,12 @@ static char preInitCmd[] = ; static const char initScript[] = -"if {[file isfile [file join $::tcl::basekit main.tcl]]} {\n" +"if {[file isfile [file join $::tcl::kitpath main.tcl]]} {\n" "if {[info commands console] != {}} { console hide }\n" "set tcl_interactive 0\n" "incr argc\n" "set argv [linsert $argv 0 $argv0]\n" - "set argv0 [file join $::tcl::basekit main.tcl]\n" + "set argv0 [file join $::tcl::kitpath main.tcl]\n" "} else continue\n" ; @@ -163,14 +166,19 @@ TclKit_AppInit(Tcl_Interp *interp) #if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 85 Tcl_StaticPackage(0, "pwb", Pwb_Init, NULL); #endif + Tcl_StaticPackage(0, "tclkitpath", TclKitPath_Init, NULL); Tcl_StaticPackage(0, "rechan", Rechan_Init, NULL); Tcl_StaticPackage(0, "vfs", Vfs_Init, NULL); Tcl_StaticPackage(0, "zlib", Zlib_Init, NULL); #ifdef TCL_THREADS - Tcl_StaticPackage(0, "Thread", Thread_Init, NULL); + Tcl_StaticPackage(0, "Thread", Thread_Init, Thread_SafeInit); #endif #ifdef _WIN32 +#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION > 84 + Tcl_StaticPackage(0, "dde", Dde_Init, Dde_SafeInit); +#else Tcl_StaticPackage(0, "dde", Dde_Init, NULL); +#endif Tcl_StaticPackage(0, "registry", Registry_Init, NULL); #endif #ifdef KIT_INCLUDES_TK @@ -186,47 +194,6 @@ TclKit_AppInit(Tcl_Interp *interp) Tcl_SetVar(interp, "tcl_rcFileName", "~/.tclkitrc", TCL_GLOBAL_ONLY); #endif - if (tclKitPath != NULL) { - /* - * If we have a tclKitPath set, then set that to ::tcl::basekit. - * This will be used instead of 'info nameofexecutable' for - * determining the location of the base kit. This is necessary - * for DLL-based starkits. - * - * This code equates to: - * namespace eval ::tcl [list variable basekit $tclKitPath] - * Could consider using Tcl_LinkVar instead. - */ - Tcl_Obj *objPtr; - Tcl_Obj *evobjPtr; - - evobjPtr = Tcl_NewObj(); - Tcl_ListObjAppendElement(interp, evobjPtr, - Tcl_NewStringObj("variable", -1)); - Tcl_ListObjAppendElement(interp, evobjPtr, - Tcl_NewStringObj("basekit", -1)); - Tcl_ListObjAppendElement(interp, evobjPtr, - Tcl_NewStringObj(tclKitPath, -1)); - Tcl_IncrRefCount(evobjPtr); - - objPtr = Tcl_NewObj(); - Tcl_ListObjAppendElement(interp, objPtr, - Tcl_NewStringObj("namespace", -1)); - Tcl_ListObjAppendElement(interp, objPtr, - Tcl_NewStringObj("eval", -1)); - Tcl_ListObjAppendElement(interp, objPtr, - Tcl_NewStringObj("::tcl", -1)); - Tcl_ListObjAppendElement(interp, objPtr, evobjPtr); - Tcl_IncrRefCount(objPtr); - if (Tcl_EvalObjEx(interp, objPtr, TCL_GLOBAL_ONLY) != TCL_OK) { - Tcl_DecrRefCount(objPtr); - Tcl_DecrRefCount(evobjPtr); - goto error; - } - Tcl_DecrRefCount(objPtr); - Tcl_DecrRefCount(evobjPtr); - } - #if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION > 84 { Tcl_DString encodingName; @@ -240,16 +207,10 @@ TclKit_AppInit(Tcl_Interp *interp) } #endif -#ifdef KIT_DLL TclSetPreInitScript(preInitCmd); if ((Tcl_EvalEx(interp, appInitCmd, -1, TCL_EVAL_GLOBAL) == TCL_ERROR) || (Tcl_Init(interp) == TCL_ERROR)) goto error; -#else /* not a dll */ - TclSetPreInitScript(appInitCmd); - if (Tcl_Init(interp) == TCL_ERROR) - goto error; -#endif #if defined(KIT_INCLUDES_TK) && defined(_WIN32) if (Tk_Init(interp) == TCL_ERROR) @@ -259,11 +220,12 @@ TclKit_AppInit(Tcl_Interp *interp) #endif /* messy because TclSetStartupScriptPath is called slightly too late */ - if (Tcl_Eval(interp, initScript) == TCL_OK) { + if (Tcl_EvalEx(interp, initScript, -1, TCL_EVAL_GLOBAL) == TCL_OK) { Tcl_Obj* path = TclGetStartupScriptPath(); TclSetStartupScriptPath(Tcl_GetObjResult(interp)); - if (path == NULL) - Tcl_Eval(interp, "incr argc -1; set argv [lrange $argv 1 end]"); + if (path == NULL) { + Tcl_Eval(interp, "incr argc -1; set argv [lrange $argv 1 end]"); + } } Tcl_SetVar(interp, "errorInfo", "", TCL_GLOBAL_ONLY); @@ -286,17 +248,20 @@ __declspec(dllexport) char * #else extern char * #endif -TclKit_SetKitPath(CONST char *kitPath) +TclKit_SetKitPath(const char *kitPath) { /* * Allow someone to define an alternate path to the base kit * than 'info nameofexecutable'. + * NOTE: this must be provided as a utf-8 encoded string or it may + * fail when the path includes non-ascii characters. */ if (kitPath) { int len = (int)strlen(kitPath); if (tclKitPath) { ckfree(tclKitPath); } + tclKitPath = (char *) ckalloc(len + 1); memcpy(tclKitPath, kitPath, len); tclKitPath[len] = '\0'; @@ -339,3 +304,51 @@ TclKit_InitStdChannels(void) Tcl_SetStdChannel(chan, TCL_STDERR); } } + +/* + * Accessor to true pathname of the tclkit, to work as a starpack or stardll. + */ +static int +TclKitPathObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) +{ + /* + * If we have a tclKitPath set, then set that to ::tcl::kitpath. + * This will be used instead of 'info nameofexecutable' for + * determining the location of the base kit. This is necessary + * for DLL-based starkits. + */ + char* str; + if (objc == 2) { + /* + * XXX: Should we allow people to set this? + */ + TclKit_SetKitPath(Tcl_GetString(objv[1])); + } else if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?path?"); + } + str = tclKitPath ? tclKitPath : Tcl_GetNameOfExecutable(); + Tcl_SetObjResult(interp, Tcl_NewStringObj(str, -1)); + return TCL_OK; +} + +/* + * Public entry point for ::tcl::kitpath. + * Creates both link variable name and Tcl command ::tcl::kitpath. + */ +static int +TclKitPath_Init(Tcl_Interp *interp) +{ + Tcl_CreateObjCommand(interp, "::tcl::kitpath", TclKitPathObjCmd, 0, 0); + if (Tcl_LinkVar(interp, "::tcl::kitpath", (char *) &tclKitPath, + TCL_LINK_STRING | TCL_LINK_READ_ONLY) != TCL_OK) { + Tcl_ResetResult(interp); + } + if (tclKitPath == NULL) { + /* + * XXX: We may want to avoid doing this to allow tcl::kitpath calls + * XXX: to obtain changes in nameofexe, if they occur. + */ + TclKit_SetKitPath(Tcl_GetNameOfExecutable()); + } + return Tcl_PkgProvide(interp, "tclkitpath", "1.0"); +} diff --git a/setupvfs.tcl b/setupvfs.tcl index 6a36a7a..bf37def 100644 --- a/setupvfs.tcl +++ b/setupvfs.tcl @@ -148,25 +148,28 @@ set guifiles { if {$encOpt} { lappend clifiles lib/tcl8@/encoding } else { - lappend clifiles lib/tcl8@/encoding/ascii.enc \ - lib/tcl8@/encoding/cp1251.enc \ - lib/tcl8@/encoding/cp1252.enc \ - lib/tcl8@/encoding/iso8859-1.enc \ - lib/tcl8@/encoding/iso8859-2.enc \ - lib/tcl8@/encoding/iso8859-3.enc \ - lib/tcl8@/encoding/iso8859-4.enc \ - lib/tcl8@/encoding/iso8859-5.enc \ - lib/tcl8@/encoding/iso8859-6.enc \ - lib/tcl8@/encoding/iso8859-7.enc \ - lib/tcl8@/encoding/iso8859-8.enc \ - lib/tcl8@/encoding/iso8859-9.enc \ - lib/tcl8@/encoding/iso8859-10.enc \ - lib/tcl8@/encoding/iso8859-13.enc \ - lib/tcl8@/encoding/iso8859-14.enc \ - lib/tcl8@/encoding/iso8859-15.enc \ - lib/tcl8@/encoding/iso8859-16.enc \ - lib/tcl8@/encoding/koi8-r.enc \ - lib/tcl8@/encoding/macRoman.enc + # Minimal set + #foreach e {ascii cp1251 cp1252 iso8859-1 iso8859-2 iso8859-3 + # iso8859-4 iso8859-5 iso8859-6 iso8859-7 iso8859-8 iso8859-9 + # iso8859-10 iso8859-13 iso8859-14 iso8859-15 iso8859-16 + # koi8-r macRoman} { + # lappend clifiles lib/tcl8@/encoding/$e.enc + #} + + # ActiveTcl basekit encodings: this just avoids the largest files: + # big5 cp932 cp936 cp949 cp950 euc-cn euc-jp euc-kr gn12345 gb2312 + # gb2312-raw jis0208 jis0212 ksc601 shiftjis + foreach e {ascii cp1250 cp1251 cp1252 cp1253 cp1254 cp1255 cp1256 cp1257 + cp1258 cp437 cp737 cp775 cp850 cp852 cp855 cp857 cp860 cp861 cp862 + cp863 cp864 cp865 cp866 cp869 cp874 dingbats ebcdic gb1988 + iso2022 iso2022-jp iso2022-kr iso8859-1 iso8859-10 iso8859-13 + iso8859-14 iso8859-15 iso8859-16 iso8859-2 iso8859-3 iso8859-4 + iso8859-5 iso8859-6 iso8859-7 iso8859-8 iso8859-9 jis0201 koi8-r + koi8-u macCentEuro macCroatian macCyrillic macDingbats macGreek + macIceland macRoman macRomania macThai macTurkish macUkraine + symbol tis-620} { + lappend clifiles lib/tcl8@/encoding/$e.enc + } } if {$threadOpt} { -- 2.23.0