/[dtapublic]/projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclmain.c
ViewVC logotype

Contents of /projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclmain.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 64 - (show annotations) (download)
Sun Oct 30 04:21:11 2016 UTC (7 years, 11 months ago) by dashley
File MIME type: text/plain
File size: 10379 byte(s)
Adjust line endings to Windows style.
Set properties to expand the "Header" keyword.
Change header and footer.
1 /*$Header$ */
2 /*
3 * tclMain.c --
4 *
5 * Main program for Tcl shells and other Tcl-based applications.
6 *
7 * Copyright (c) 1988-1994 The Regents of the University of California.
8 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
9 *
10 * See the file "license.terms" for information on usage and redistribution
11 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
12 *
13 * RCS: @(#) $Id: tclmain.c,v 1.2 2001/10/07 01:32:29 dtashley Exp $
14 */
15
16 #define MODULE_TCLMAIN
17
18 #include "tclmain.h"
19
20 #include "tcl.h"
21 #include "tclInt.h"
22
23 #include "build_config.h"
24 #include "extninit.h"
25 #include "msgstrs.h"
26
27
28 # undef TCL_STORAGE_CLASS
29 # define TCL_STORAGE_CLASS DLLEXPORT
30
31 /*
32 * The following code ensures that tclLink.c is linked whenever
33 * Tcl is linked. Without this code there's no reference to the
34 * code in that file from anywhere in Tcl, so it may not be
35 * linked into the application.
36 */
37
38 EXTERN int Tcl_LinkVar();
39 int (*tclDummyLinkVarPtr)() = Tcl_LinkVar;
40
41 /*
42 * Declarations for various library procedures and variables (don't want
43 * to include tclPort.h here, because people might copy this file out of
44 * the Tcl source directory to make their own modified versions).
45 * Note: "exit" should really be declared here, but there's no way to
46 * declare it without causing conflicts with other definitions elsewher
47 * on some systems, so it's better just to leave it out.
48 */
49
50 extern int isatty _ANSI_ARGS_((int fd));
51 extern char * strcpy _ANSI_ARGS_((char *dst, CONST char *src));
52
53 static char *tclStartupScriptFileName = NULL;
54
55
56
57
58 /*
59 *----------------------------------------------------------------------
60 *
61 * TclSetStartupScriptFileName --
62 *
63 * Primes the startup script file name, used to override the
64 * command line processing.
65 *
66 * Results:
67 * None.
68 *
69 * Side effects:
70 * This procedure initializes the file name of the Tcl script to
71 * run at startup.
72 *
73 *----------------------------------------------------------------------
74 */
75 void TclSetStartupScriptFileName(fileName)
76 char *fileName;
77 {
78 tclStartupScriptFileName = fileName;
79 }
80
81
82 /*
83 *----------------------------------------------------------------------
84 *
85 * TclGetStartupScriptFileName --
86 *
87 * Gets the startup script file name, used to override the
88 * command line processing.
89 *
90 * Results:
91 * The startup script file name, NULL if none has been set.
92 *
93 * Side effects:
94 * None.
95 *
96 *----------------------------------------------------------------------
97 */
98 char *TclGetStartupScriptFileName()
99 {
100 return tclStartupScriptFileName;
101 }
102
103
104
105 /*
106 *----------------------------------------------------------------------
107 *
108 * Tcl_Main --
109 *
110 * Main program for tclsh and most other Tcl-based applications.
111 *
112 * Results:
113 * None. This procedure never returns (it exits the process when
114 * it's done.
115 *
116 * Side effects:
117 * This procedure initializes the Tcl world and then starts
118 * interpreting commands; almost anything could happen, depending
119 * on the script being interpreted.
120 *
121 *----------------------------------------------------------------------
122 */
123
124 void
125 Tcl_Main(argc, argv, appInitProc)
126 int argc; /* Number of arguments. */
127 char **argv; /* Array of argument strings. */
128 Tcl_AppInitProc *appInitProc;
129 /* Application-specific initialization
130 * procedure to call after most
131 * initialization but before starting to
132 * execute commands. */
133 {
134 Tcl_Obj *resultPtr;
135 Tcl_Obj *commandPtr = NULL;
136 char buffer[1000], *args;
137 int code, gotPartial, tty, length;
138 int exitCode = 0;
139 Tcl_Channel inChannel, outChannel, errChannel;
140 Tcl_Interp *interp;
141 Tcl_DString argString;
142
143 Tcl_FindExecutable(argv[0]);
144 interp = Tcl_CreateInterp();
145 #ifdef TCL_MEM_DEBUG
146 Tcl_InitMemory(interp);
147 #endif
148
149 /*
150 * Make command-line arguments available in the Tcl variables "argc"
151 * and "argv". If the first argument doesn't start with a "-" then
152 * strip it off and use it as the name of a script file to process.
153 */
154
155 if (tclStartupScriptFileName == NULL) {
156 if ((argc > 1) && (argv[1][0] != '-')) {
157 tclStartupScriptFileName = argv[1];
158 argc--;
159 argv++;
160 }
161 }
162 args = Tcl_Merge(argc-1, argv+1);
163 Tcl_ExternalToUtfDString(NULL, args, -1, &argString);
164 Tcl_SetVar(interp, "argv", Tcl_DStringValue(&argString), TCL_GLOBAL_ONLY);
165 Tcl_DStringFree(&argString);
166 ckfree(args);
167
168 if (tclStartupScriptFileName == NULL) {
169 Tcl_ExternalToUtfDString(NULL, argv[0], -1, &argString);
170 } else {
171 tclStartupScriptFileName = Tcl_ExternalToUtfDString(NULL,
172 tclStartupScriptFileName, -1, &argString);
173 }
174
175 TclFormatInt(buffer, argc-1);
176 Tcl_SetVar(interp, "argc", buffer, TCL_GLOBAL_ONLY);
177 Tcl_SetVar(interp, "argv0", Tcl_DStringValue(&argString), TCL_GLOBAL_ONLY);
178
179 /*
180 * Set the "tcl_interactive" variable.
181 */
182
183 tty = isatty(0);
184 Tcl_SetVar(interp, "tcl_interactive",
185 ((tclStartupScriptFileName == NULL) && tty) ? "1" : "0",
186 TCL_GLOBAL_ONLY);
187
188 /*
189 * Invoke application-specific initialization.
190 */
191
192 /* Register any extensions that should be registered for the
193 ** executable currently being built.
194 */
195 ExtninitInit(interp);
196
197 /* Set a Tcl variable to indicate the particular product
198 ** we are building. This is used in the startup message script
199 ** to announce product version, and may be used other
200 ** places, as well.
201 */
202 Tcl_SetVar(interp,
203 BUILD_CONFIG_PRODUCT_NAME_VARIABLE,
204 BUILD_CONFIG_STATIC_TCLSH_ALIAS,
205 TCL_GLOBAL_ONLY);
206
207 /* Set Tcl variable to indicate the relese version of the
208 ** product we are building. This is used in the startup message script
209 ** to announce product version, and may be used other
210 ** places, as well.
211 */
212 Tcl_SetVar(interp,
213 BUILD_CONFIG_PRODUCT_VERSION_VARIABLE,
214 BUILD_CONFIG_RELEASE_VERSION,
215 TCL_GLOBAL_ONLY);
216
217 /* Output the introductory message to the console.
218 ** The script called is generic and applies to both
219 ** IjuScripter and IjuConsole.
220 */
221 Tcl_GlobalEval(interp, BUILD_CONFIG_StartupMessageScript);
222
223 /*
224 * If a script file was specified then just source that file
225 * and quit.
226 */
227
228 if (tclStartupScriptFileName != NULL) {
229 code = Tcl_EvalFile(interp, tclStartupScriptFileName);
230 if (code != TCL_OK) {
231 errChannel = Tcl_GetStdChannel(TCL_STDERR);
232 if (errChannel) {
233 /*
234 * The following statement guarantees that the errorInfo
235 * variable is set properly.
236 */
237
238 Tcl_AddErrorInfo(interp, "");
239 Tcl_WriteObj(errChannel, Tcl_GetVar2Ex(interp, "errorInfo",
240 NULL, TCL_GLOBAL_ONLY));
241 Tcl_WriteChars(errChannel, "\n", 1);
242 }
243 exitCode = 1;
244 }
245 goto done;
246 }
247 Tcl_DStringFree(&argString);
248
249 /*
250 * We're running interactively. Source a user-specific startup
251 * file if the application specified one and if the file exists.
252 */
253
254 Tcl_SourceRCFile(interp);
255
256 /*
257 * Process commands from stdin until there's an end-of-file. Note
258 * that we need to fetch the standard channels again after every
259 * eval, since they may have been changed.
260 */
261
262 commandPtr = Tcl_NewObj();
263 Tcl_IncrRefCount(commandPtr);
264
265 inChannel = Tcl_GetStdChannel(TCL_STDIN);
266 outChannel = Tcl_GetStdChannel(TCL_STDOUT);
267 gotPartial = 0;
268 while (1) {
269 if (tty) {
270 Tcl_Obj *promptCmdPtr;
271
272 promptCmdPtr = Tcl_GetVar2Ex(interp,
273 (gotPartial ? "tcl_prompt2" : "tcl_prompt1"),
274 NULL, TCL_GLOBAL_ONLY);
275 if (promptCmdPtr == NULL) {
276 defaultPrompt:
277 if (!gotPartial && outChannel) {
278 Tcl_WriteChars(outChannel, "% ", 2);
279 }
280 } else {
281 code = Tcl_EvalObjEx(interp, promptCmdPtr, 0);
282 inChannel = Tcl_GetStdChannel(TCL_STDIN);
283 outChannel = Tcl_GetStdChannel(TCL_STDOUT);
284 errChannel = Tcl_GetStdChannel(TCL_STDERR);
285 if (code != TCL_OK) {
286 if (errChannel) {
287 Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
288 Tcl_WriteChars(errChannel, "\n", 1);
289 }
290 Tcl_AddErrorInfo(interp,
291 "\n (script that generates prompt)");
292 goto defaultPrompt;
293 }
294 }
295 if (outChannel) {
296 Tcl_Flush(outChannel);
297 }
298 }
299 if (!inChannel) {
300 goto done;
301 }
302 length = Tcl_GetsObj(inChannel, commandPtr);
303 if (length < 0) {
304 goto done;
305 }
306 if ((length == 0) && Tcl_Eof(inChannel) && (!gotPartial)) {
307 goto done;
308 }
309
310 /*
311 * Add the newline removed by Tcl_GetsObj back to the string.
312 */
313
314 Tcl_AppendToObj(commandPtr, "\n", 1);
315 if (!TclObjCommandComplete(commandPtr)) {
316 gotPartial = 1;
317 continue;
318 }
319
320 gotPartial = 0;
321 code = Tcl_RecordAndEvalObj(interp, commandPtr, 0);
322 inChannel = Tcl_GetStdChannel(TCL_STDIN);
323 outChannel = Tcl_GetStdChannel(TCL_STDOUT);
324 errChannel = Tcl_GetStdChannel(TCL_STDERR);
325 Tcl_DecrRefCount(commandPtr);
326 commandPtr = Tcl_NewObj();
327 Tcl_IncrRefCount(commandPtr);
328 if (code != TCL_OK) {
329 if (errChannel) {
330 Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
331 Tcl_WriteChars(errChannel, "\n", 1);
332 }
333 } else if (tty) {
334 resultPtr = Tcl_GetObjResult(interp);
335 Tcl_GetStringFromObj(resultPtr, &length);
336 if ((length > 0) && outChannel) {
337 Tcl_WriteObj(outChannel, resultPtr);
338 Tcl_WriteChars(outChannel, "\n", 1);
339 }
340 }
341 #ifdef TCL_MEM_DEBUG
342 if (tclMemDumpFileName != NULL) {
343 Tcl_DecrRefCount(commandPtr);
344 Tcl_DeleteInterp(interp);
345 Tcl_Exit(0);
346 }
347 #endif
348 }
349
350 /*
351 * Rather than calling exit, invoke the "exit" command so that
352 * users can replace "exit" with some other command to do additional
353 * cleanup on exit. The Tcl_Eval call should never return.
354 */
355
356 done:
357 if (commandPtr != NULL) {
358 Tcl_DecrRefCount(commandPtr);
359 }
360 sprintf(buffer, "exit %d", exitCode);
361 Tcl_Eval(interp, buffer);
362 }
363
364
365 const char *TclMainCversion(void)
366 {
367 return ("$Header$");
368 }
369
370
371 const char *TclMainHversion(void)
372 {
373 return (TCLMAIN_H_VERSION);
374 }
375
376 /* End of tclmain.c */

Properties

Name Value
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25