/* * tclAppInit.c -- * * Provides a default version of the main program and Tcl_AppInit * procedure for Tcl applications (without Tk). Note that this * program must be built in Win32 console mode to work properly. * * Copyright (c) 1996-1997 by Sun Microsystems, Inc. * 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. * * RCS: @(#) $Id$ */ #ifdef KIT_INCLUDES_TK #include #else #include #endif /* define this to use the zlib package */ #ifndef KIT_INCLUDES_ZLIB #if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 86 #define KIT_INCLUDES_ZLIB 1 #else #define KIT_INCLUDES_ZLIB 0 #endif #endif #include #ifdef _WIN32 #define WIN32_LEAN_AND_MEAN #include #undef WIN32_LEAN_AND_MEAN #endif /* defined in tclInt.h */ #if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 86 extern Tcl_Obj* TclGetStartupScriptPath(); extern void TclSetStartupScriptPath(Tcl_Obj*); #define Tcl_GetStartupScript(encPtr) TclGetStartupScriptPath() #define Tcl_SetStartupScript(path,enc) TclSetStartupScriptPath(path) #endif extern char* TclSetPreInitScript (char*); Tcl_AppInitProc Pwb_Init, Rechan_Init, Vfs_Init; #ifdef KIT_LITE Tcl_AppInitProc Vlerq_Init, Vlerq_SafeInit; #else Tcl_AppInitProc Mk4tcl_Init; #endif #ifdef TCL_THREADS Tcl_AppInitProc Thread_Init; #endif #if KIT_INCLUDES_ZLIB Tcl_AppInitProc Zlib_Init; #endif #ifdef KIT_INCLUDES_ITCL Tcl_AppInitProc Itcl_Init; #endif #ifdef _WIN32 Tcl_AppInitProc Dde_Init, Dde_SafeInit, Registry_Init; #endif static Tcl_AppInitProc TclKitPath_Init; /* insert custom prototypes here */ #ifdef WIN32 #define DEV_NULL "NUL" #else #define DEV_NULL "/dev/null" #endif static void TclKit_InitStdChannels(void); /* * Attempt to load a "boot.tcl" entry from the embedded MetaKit file. * This code uses either the Mk4tcl or the vlerq extension (-DKIT_LITE). * If there isn't one, try to open a regular "setup.tcl" file instead. * If that fails, this code will throw an error, using a message box. * * The tclKitPreInit script gets run for every interpreter and there are * guards in the boot.tcl to avoid re-initializing things than do not need * it. This is required to make child interpreters and thread interps * initialize properly. */ static char preInitCmd[] = "proc tclKitPreInit {} {\n" "rename tclKitPreInit {}\n" "load {} tclkitpath\n" /*"puts \"appInit: [encoding system] $::tcl::kitpath\"\n"*/ #if KIT_INCLUDES_ZLIB "catch {load {} zlib}\n" #endif #ifdef KIT_LITE "load {} vlerq\n" "namespace eval ::vlerq {}\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" "set n [lsearch [vlerq get $files * name] boot.tcl]\n" "}\n" "if {$n >= 0} {\n" "array set a [vlerq get $files $n]\n" #else "load {} Mk4tcl\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" #endif "if {![info exists a(contents)]} { error {no boot.tcl file} }\n" "if {$a(size) != [string length $a(contents)]} {\n" "set a(contents) [zlib decompress $a(contents)]\n" "}\n" "if {$a(contents) eq \"\"} { error {empty boot.tcl} }\n" "uplevel #0 $a(contents)\n" "} elseif {[lindex $::argv 0] eq \"-init-\"} {\n" "uplevel #0 { source [lindex $::argv 1] }\n" "exit\n" "} else {\n" "error \"\n $::tcl::kitpath has no VFS data to start up\"\n" "}\n" "}\n" "tclKitPreInit" ; static const char initScript[] = "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::kitpath main.tcl]\n" "} else continue\n" ; /* * If set, this is the path to the base kit */ static char *tclKitPath = NULL; #ifdef WIN32 __declspec(dllexport) int #else extern int #endif TclKit_AppInit(Tcl_Interp *interp) { /* * Ensure that std channels exist (creating them if necessary) */ TclKit_InitStdChannels(); #ifdef KIT_INCLUDES_ITCL Tcl_StaticPackage(0, "Itcl", Itcl_Init, NULL); #endif #ifdef KIT_LITE Tcl_StaticPackage(0, "vlerq", Vlerq_Init, Vlerq_SafeInit); #else Tcl_StaticPackage(0, "Mk4tcl", Mk4tcl_Init, NULL); #endif #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); #if KIT_INCLUDES_ZLIB Tcl_StaticPackage(0, "zlib", Zlib_Init, NULL); #endif #ifdef TCL_THREADS 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_StaticPackage(0, "Tk", Tk_Init, Tk_SafeInit); #endif /* insert custom packages here */ /* the tcl_rcFileName variable only exists in the initial interpreter */ #ifdef _WIN32 Tcl_SetVar(interp, "tcl_rcFileName", "~/tclkitrc.tcl", TCL_GLOBAL_ONLY); #else Tcl_SetVar(interp, "tcl_rcFileName", "~/.tclkitrc", TCL_GLOBAL_ONLY); #endif #if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION > 84 { Tcl_DString encodingName; Tcl_GetEncodingNameFromEnvironment(&encodingName); if (strcmp(Tcl_DStringValue(&encodingName), Tcl_GetEncodingName(NULL))) { /* fails, so we set a variable and do it in the boot.tcl script */ Tcl_SetSystemEncoding(NULL, Tcl_DStringValue(&encodingName)); } Tcl_SetVar(interp, "tclkit_system_encoding", Tcl_DStringValue(&encodingName), 0); Tcl_DStringFree(&encodingName); } #endif TclSetPreInitScript(preInitCmd); if (Tcl_Init(interp) == TCL_ERROR) goto error; #if defined(KIT_INCLUDES_TK) && defined(_WIN32) if (Tk_Init(interp) == TCL_ERROR) goto error; if (Tk_CreateConsoleWindow(interp) == TCL_ERROR) goto error; #endif /* messy because TclSetStartupScriptPath is called slightly too late */ if (Tcl_EvalEx(interp, initScript, -1, TCL_EVAL_GLOBAL) == TCL_OK) { const char *encoding = NULL; Tcl_Obj* path = Tcl_GetStartupScript(&encoding); Tcl_SetStartupScript(Tcl_GetObjResult(interp), encoding); if (path == NULL) { Tcl_Eval(interp, "incr argc -1; set argv [lrange $argv 1 end]"); } } Tcl_SetVar(interp, "errorInfo", "", TCL_GLOBAL_ONLY); Tcl_ResetResult(interp); return TCL_OK; error: #if defined(KIT_INCLUDES_TK) && defined(_WIN32) MessageBeep(MB_ICONEXCLAMATION); MessageBox(NULL, Tcl_GetStringResult(interp), "Error in Tclkit", MB_ICONSTOP | MB_OK | MB_TASKMODAL | MB_SETFOREGROUND); ExitProcess(1); /* we won't reach this, but we need the return */ #endif return TCL_ERROR; } #ifdef WIN32 __declspec(dllexport) char * #else extern char * #endif 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'; } return tclKitPath; } static void TclKit_InitStdChannels(void) { Tcl_Channel chan; /* * We need to verify if we have the standard channels and create them if * not. Otherwise internals channels may get used as standard channels * (like for encodings) and panic. */ chan = Tcl_GetStdChannel(TCL_STDIN); if (chan == NULL) { chan = Tcl_OpenFileChannel(NULL, DEV_NULL, "r", 0); if (chan != NULL) { Tcl_SetChannelOption(NULL, chan, "-encoding", "utf-8"); } Tcl_SetStdChannel(chan, TCL_STDIN); } chan = Tcl_GetStdChannel(TCL_STDOUT); if (chan == NULL) { chan = Tcl_OpenFileChannel(NULL, DEV_NULL, "w", 0); if (chan != NULL) { Tcl_SetChannelOption(NULL, chan, "-encoding", "utf-8"); } Tcl_SetStdChannel(chan, TCL_STDOUT); } chan = Tcl_GetStdChannel(TCL_STDERR); if (chan == NULL) { chan = Tcl_OpenFileChannel(NULL, DEV_NULL, "w", 0); if (chan != NULL) { Tcl_SetChannelOption(NULL, chan, "-encoding", "utf-8"); } 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"); }