/* * 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. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: kitInit.c,v 1.3 2008/05/11 20:36:50 demin Exp $ */ #ifdef KIT_INCLUDES_TK #include #else #include #endif #include #ifdef _WIN32 #define WIN32_LEAN_AND_MEAN #include #undef WIN32_LEAN_AND_MEAN #endif /* defined in tclInt.h */ extern Tcl_Obj* TclGetStartupScriptPath(); extern void TclSetStartupScriptPath(Tcl_Obj*); Tcl_AppInitProc Vfs_Init, Zlib_Init; #ifdef TCL_THREADS Tcl_AppInitProc Thread_Init; #endif #ifdef _WIN32 Tcl_AppInitProc Dde_Init, Registry_Init; #endif #ifdef KIT_INCLUDES_TK Tcl_AppInitProc Blt_Init, Blt_SafeInit; Tcl_AppInitProc Tktable_Init, Tktable_SafeInit; #endif Tcl_AppInitProc Tdom_Init, Tdom_SafeInit; Tcl_AppInitProc G2lite_Init; Tcl_AppInitProc Usb_Init; Tcl_AppInitProc Swt_Init; Tcl_AppInitProc Csr_Init; Tcl_AppInitProc Xotcl_Init; Tcl_AppInitProc Sqlite3_Init; #ifdef WIN32 #define DEV_NULL "NUL" #else #define DEV_NULL "/dev/null" #endif static void TclKit_InitStdChannels(void); static char appInitCmd[] = "proc tclKitInit {} {\n" "rename tclKitInit {}\n" "if {![info exists ::tcl::basekit]} {\n" "namespace eval ::tcl { variable basekit [info nameofexecutable] }\n" "}\n" "if {[file isfile /zvfs/boot.tcl]} {\n" "source /zvfs/boot.tcl\n" "} elseif {[lindex $::argv 0] eq \"-init-\"} {\n" "uplevel #0 { source [lindex $::argv 1] }\n" "exit\n" "} else {\n" "error \"\n $::tcl::basekit has no VFS data to start up\"\n" "}\n" "}\n" "tclKitInit" ; static const char initScript[] = "if {[file isfile [file join /zvfs 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 /zvfs main.tcl]\n" "} else continue\n" ; #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(); Tcl_StaticPackage(0, "vfs", Vfs_Init, NULL); Tcl_StaticPackage(0, "zlib", Zlib_Init, NULL); #ifdef TCL_THREADS Tcl_StaticPackage(0, "Thread", Thread_Init, NULL); #endif #ifdef _WIN32 Tcl_StaticPackage(0, "dde", Dde_Init, NULL); Tcl_StaticPackage(0, "registry", Registry_Init, NULL); #endif #ifdef KIT_INCLUDES_TK Tcl_StaticPackage(0, "Tk", Tk_Init, Tk_SafeInit); Tcl_StaticPackage(0, "Blt", Blt_Init, Blt_SafeInit); Tcl_StaticPackage(0, "Tktable", Tktable_Init, Tktable_SafeInit); #endif Tcl_StaticPackage(0, "XOTcl", Xotcl_Init, NULL); Tcl_StaticPackage(0, "g2lite", G2lite_Init, NULL); Tcl_StaticPackage(0, "usb", Usb_Init, NULL); Tcl_StaticPackage(0, "swt", Swt_Init, NULL); Tcl_StaticPackage(0, "csr", Csr_Init, NULL); Tcl_StaticPackage(0, "sqlite3", Sqlite3_Init, NULL); Tcl_StaticPackage(0, "tdom", Tdom_Init, Tdom_SafeInit); /* 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 Zvfs_Init(interp); Tcl_SetVar(interp, "extname", "", TCL_GLOBAL_ONLY); Zvfs_Mount(interp, (char *)Tcl_GetNameOfExecutable(), "/zvfs"); Tcl_SetVar2(interp, "env", "TCL_LIBRARY", "/zvfs/lib/tcl", TCL_GLOBAL_ONLY); Tcl_SetVar2(interp, "env", "TK_LIBRARY", "/zvfs/lib/tk", TCL_GLOBAL_ONLY); if ((Tcl_EvalEx(interp, appInitCmd, -1, TCL_EVAL_GLOBAL) == TCL_ERROR) || (Tcl_Init(interp) == TCL_ERROR)) goto error; #ifdef KIT_INCLUDES_TK if (Tk_Init(interp) == TCL_ERROR) goto error; #ifdef _WIN32 if (Tk_CreateConsoleWindow(interp) == TCL_ERROR) goto error; #endif #endif /* messy because TclSetStartupScriptPath is called slightly too late */ if (Tcl_Eval(interp, initScript) == 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]"); } 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; } 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); } }