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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 64 - (hide annotations) (download)
Sun Oct 30 04:21:11 2016 UTC (7 years, 3 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 dashley 64 /*$Header$ */
2 dashley 25 /*
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 dashley 64 return ("$Header$");
368 dashley 25 }
369    
370    
371     const char *TclMainHversion(void)
372     {
373     return (TCLMAIN_H_VERSION);
374     }
375    
376 dashley 64 /* End of tclmain.c */

Properties

Name Value
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25