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
}
* Copyright (c) 1998-1999 by Scriptics Corporation.
* Copyright (c) 2000-2006 Jean-Claude Wippler <jcw@equi4.com>
* Copyright (c) 2003-2006 ActiveState Software Inc.
+ * Copyright (c) 2007-2008 Pat Thoyts <patthoyts@users.sourceforge.net>
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
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
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"
"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"
"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"
"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"
;
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"
;
#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
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;
}
#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)
#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);
#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';
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");
+}
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} {
projects / kitgen / commitdiff