source: trunk/kitgen/kitInit.c@ 182

Last change on this file since 182 was 175, checked in by demin, 12 years ago

initial commit
File size: 6.0 KB
Line 
1/*
2 * tclAppInit.c --
3 *
4 * Provides a default version of the main program and Tcl_AppInit
5 * procedure for Tcl applications (without Tk). Note that this
6 * program must be built in Win32 console mode to work properly.
7 *
8 * Copyright (c) 1996-1997 by Sun Microsystems, Inc.
9 * Copyright (c) 1998-1999 by Scriptics Corporation.
10 * Copyright (c) 2000-2006 Jean-Claude Wippler <jcw@equi4.com>
11 * Copyright (c) 2003-2006 ActiveState Software Inc.
12 *
13 * See the file "license.terms" for information on usage and redistribution
14 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
15 *
16 * RCS: @(#) $Id: kitInit.c,v 1.3 2008/05/11 20:36:50 demin Exp $
17 */
18
19#ifdef KIT_INCLUDES_TK
20#include <tk.h>
21#else
22#include <tcl.h>
23#endif
24
25#include <string.h>
26
27#ifdef _WIN32
28#define WIN32_LEAN_AND_MEAN
29#include <windows.h>
30#undef WIN32_LEAN_AND_MEAN
31#endif
32
33/* defined in tclInt.h */
34extern Tcl_Obj* TclGetStartupScriptPath();
35extern void TclSetStartupScriptPath(Tcl_Obj*);
36
37Tcl_AppInitProc Vfs_Init, Zlib_Init;
38#ifdef TCL_THREADS
39Tcl_AppInitProc Thread_Init;
40#endif
41#ifdef _WIN32
42Tcl_AppInitProc Dde_Init, Registry_Init;
43#endif
44#ifdef KIT_INCLUDES_TK
45Tcl_AppInitProc Blt_Init, Blt_SafeInit;
46#endif
47
48Tcl_AppInitProc Tdom_Init, Tdom_SafeInit;
49Tcl_AppInitProc G2lite_Init;
50Tcl_AppInitProc Usb_Init;
51Tcl_AppInitProc Swt_Init;
52Tcl_AppInitProc Csr_Init;
53Tcl_AppInitProc Xotcl_Init;
54Tcl_AppInitProc Sqlite3_Init;
55
56#ifdef WIN32
57#define DEV_NULL "NUL"
58#else
59#define DEV_NULL "/dev/null"
60#endif
61
62static void TclKit_InitStdChannels(void);
63
64static char appInitCmd[] =
65"proc tclKitInit {} {\n"
66 "rename tclKitInit {}\n"
67 "if {![info exists ::tcl::basekit]} {\n"
68 "namespace eval ::tcl { variable basekit [info nameofexecutable] }\n"
69 "}\n"
70 "if {[file isfile /zvfs/boot.tcl]} {\n"
71 "source /zvfs/boot.tcl\n"
72 "} elseif {[lindex $::argv 0] eq \"-init-\"} {\n"
73 "uplevel #0 { source [lindex $::argv 1] }\n"
74 "exit\n"
75 "} else {\n"
76 "error \"\n $::tcl::basekit has no VFS data to start up\"\n"
77 "}\n"
78"}\n"
79"tclKitInit"
80;
81
82static const char initScript[] =
83"if {[file isfile [file join /zvfs main.tcl]]} {\n"
84 "if {[info commands console] != {}} { console hide }\n"
85 "set tcl_interactive 0\n"
86 "incr argc\n"
87 "set argv [linsert $argv 0 $argv0]\n"
88 "set argv0 [file join /zvfs main.tcl]\n"
89"} else continue\n"
90;
91
92#ifdef WIN32
93__declspec(dllexport) int
94#else
95extern int
96#endif
97TclKit_AppInit(Tcl_Interp *interp)
98{
99 /*
100 * Ensure that std channels exist (creating them if necessary)
101 */
102 TclKit_InitStdChannels();
103
104 Tcl_StaticPackage(0, "vfs", Vfs_Init, NULL);
105 Tcl_StaticPackage(0, "zlib", Zlib_Init, NULL);
106#ifdef TCL_THREADS
107 Tcl_StaticPackage(0, "Thread", Thread_Init, NULL);
108#endif
109#ifdef _WIN32
110 Tcl_StaticPackage(0, "dde", Dde_Init, NULL);
111 Tcl_StaticPackage(0, "registry", Registry_Init, NULL);
112#endif
113#ifdef KIT_INCLUDES_TK
114 Tcl_StaticPackage(0, "Tk", Tk_Init, Tk_SafeInit);
115 Tcl_StaticPackage(0, "Blt", Blt_Init, Blt_SafeInit);
116#endif
117
118 Tcl_StaticPackage(0, "XOTcl", Xotcl_Init, NULL);
119 Tcl_StaticPackage(0, "g2lite", G2lite_Init, NULL);
120 Tcl_StaticPackage(0, "usb", Usb_Init, NULL);
121 Tcl_StaticPackage(0, "swt", Swt_Init, NULL);
122 Tcl_StaticPackage(0, "csr", Csr_Init, NULL);
123 Tcl_StaticPackage(0, "sqlite3", Sqlite3_Init, NULL);
124 Tcl_StaticPackage(0, "tdom", Tdom_Init, Tdom_SafeInit);
125
126 /* the tcl_rcFileName variable only exists in the initial interpreter */
127#ifdef _WIN32
128 Tcl_SetVar(interp, "tcl_rcFileName", "~/tclkitrc.tcl", TCL_GLOBAL_ONLY);
129#else
130 Tcl_SetVar(interp, "tcl_rcFileName", "~/.tclkitrc", TCL_GLOBAL_ONLY);
131#endif
132
133 Zvfs_Init(interp);
134 Tcl_SetVar(interp, "extname", "", TCL_GLOBAL_ONLY);
135 Zvfs_Mount(interp, (char *)Tcl_GetNameOfExecutable(), "/zvfs");
136 Tcl_SetVar2(interp, "env", "TCL_LIBRARY", "/zvfs/lib/tcl", TCL_GLOBAL_ONLY);
137 Tcl_SetVar2(interp, "env", "TK_LIBRARY", "/zvfs/lib/tk", TCL_GLOBAL_ONLY);
138
139 if ((Tcl_EvalEx(interp, appInitCmd, -1, TCL_EVAL_GLOBAL) == TCL_ERROR)
140 || (Tcl_Init(interp) == TCL_ERROR))
141 goto error;
142
143#ifdef KIT_INCLUDES_TK
144 if (Tk_Init(interp) == TCL_ERROR)
145 goto error;
146#ifdef _WIN32
147 if (Tk_CreateConsoleWindow(interp) == TCL_ERROR)
148 goto error;
149#endif
150#endif
151
152 /* messy because TclSetStartupScriptPath is called slightly too late */
153 if (Tcl_Eval(interp, initScript) == TCL_OK) {
154 Tcl_Obj* path = TclGetStartupScriptPath();
155 TclSetStartupScriptPath(Tcl_GetObjResult(interp));
156 if (path == NULL)
157 Tcl_Eval(interp, "incr argc -1; set argv [lrange $argv 1 end]");
158 }
159
160 Tcl_SetVar(interp, "errorInfo", "", TCL_GLOBAL_ONLY);
161 Tcl_ResetResult(interp);
162 return TCL_OK;
163
164error:
165#if defined(KIT_INCLUDES_TK) && defined(_WIN32)
166 MessageBeep(MB_ICONEXCLAMATION);
167 MessageBox(NULL, Tcl_GetStringResult(interp), "Error in Tclkit",
168 MB_ICONSTOP | MB_OK | MB_TASKMODAL | MB_SETFOREGROUND);
169 ExitProcess(1);
170 /* we won't reach this, but we need the return */
171#endif
172 return TCL_ERROR;
173}
174
175static void
176TclKit_InitStdChannels(void)
177{
178 Tcl_Channel chan;
179
180 /*
181 * We need to verify if we have the standard channels and create them if
182 * not. Otherwise internals channels may get used as standard channels
183 * (like for encodings) and panic.
184 */
185 chan = Tcl_GetStdChannel(TCL_STDIN);
186 if (chan == NULL) {
187 chan = Tcl_OpenFileChannel(NULL, DEV_NULL, "r", 0);
188 if (chan != NULL) {
189 Tcl_SetChannelOption(NULL, chan, "-encoding", "utf-8");
190 }
191 Tcl_SetStdChannel(chan, TCL_STDIN);
192 }
193 chan = Tcl_GetStdChannel(TCL_STDOUT);
194 if (chan == NULL) {
195 chan = Tcl_OpenFileChannel(NULL, DEV_NULL, "w", 0);
196 if (chan != NULL) {
197 Tcl_SetChannelOption(NULL, chan, "-encoding", "utf-8");
198 }
199 Tcl_SetStdChannel(chan, TCL_STDOUT);
200 }
201 chan = Tcl_GetStdChannel(TCL_STDERR);
202 if (chan == NULL) {
203 chan = Tcl_OpenFileChannel(NULL, DEV_NULL, "w", 0);
204 if (chan != NULL) {
205 Tcl_SetChannelOption(NULL, chan, "-encoding", "utf-8");
206 }
207 Tcl_SetStdChannel(chan, TCL_STDERR);
208 }
209}
Note: See TracBrowser for help on using the repository browser.