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

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

Parent Directory Parent Directory | Revision Log Revision Log


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

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25