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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 42 - (hide annotations) (download)
Fri Oct 14 01:50:00 2016 UTC (8 years ago) by dashley
File MIME type: text/plain
File size: 10830 byte(s)
Move shared source code to commonize.
1 dashley 25 /* $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