shared_source/c_tcl_base_7_5_w_mods/tclmain.c

/* $Header$ */
/* 
 * tclMain.c --
 *
 *      Main program for Tcl shells and other Tcl-based applications.
 *
 * Copyright (c) 1988-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclmain.c,v 1.2 2001/10/07 01:32:29 dtashley Exp $
 */

#define MODULE_TCLMAIN

#include "tclmain.h"

#include "tcl.h"
#include "tclInt.h"

#include "build_config.h"
#include "extninit.h"
#include "msgstrs.h"


# undef TCL_STORAGE_CLASS
# define TCL_STORAGE_CLASS DLLEXPORT

/*
 * The following code ensures that tclLink.c is linked whenever
 * Tcl is linked.  Without this code there's no reference to the
 * code in that file from anywhere in Tcl, so it may not be
 * linked into the application.
 */

EXTERN int Tcl_LinkVar();
int (*tclDummyLinkVarPtr)() = Tcl_LinkVar;

/*
 * Declarations for various library procedures and variables (don't want
 * to include tclPort.h here, because people might copy this file out of
 * the Tcl source directory to make their own modified versions).
 * Note:  "exit" should really be declared here, but there's no way to
 * declare it without causing conflicts with other definitions elsewher
 * on some systems, so it's better just to leave it out.
 */

extern int              isatty _ANSI_ARGS_((int fd));
extern char *           strcpy _ANSI_ARGS_((char *dst, CONST char *src));

static char *tclStartupScriptFileName = NULL;


/*
 *----------------------------------------------------------------------
 *
 * TclSetStartupScriptFileName --
 *
 *      Primes the startup script file name, used to override the
 *      command line processing.
 *
 * Results:
 *      None. 
 *
 * Side effects:
 *      This procedure initializes the file name of the Tcl script to
 *      run at startup.
 *
 *----------------------------------------------------------------------
 */
void TclSetStartupScriptFileName(fileName)
    char *fileName;
{
    tclStartupScriptFileName = fileName;
}


/*
 *----------------------------------------------------------------------
 *
 * TclGetStartupScriptFileName --
 *
 *      Gets the startup script file name, used to override the
 *      command line processing.
 *
 * Results:
 *      The startup script file name, NULL if none has been set.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */
char *TclGetStartupScriptFileName()
{
    return tclStartupScriptFileName;
}


/*
 *----------------------------------------------------------------------
 *
 * Tcl_Main --
 *
 *      Main program for tclsh and most other Tcl-based applications.
 *
 * Results:
 *      None. This procedure never returns (it exits the process when
 *      it's done.
 *
 * Side effects:
 *      This procedure initializes the Tcl world and then starts
 *      interpreting commands;  almost anything could happen, depending
 *      on the script being interpreted.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_Main(argc, argv, appInitProc)
    int argc;                   /* Number of arguments. */
    char **argv;                /* Array of argument strings. */
    Tcl_AppInitProc *appInitProc;
                                /* Application-specific initialization
                                 * procedure to call after most
                                 * initialization but before starting to
                                 * execute commands. */
{
    Tcl_Obj *resultPtr;
    Tcl_Obj *commandPtr = NULL;
    char buffer[1000], *args;
    int code, gotPartial, tty, length;
    int exitCode = 0;
    Tcl_Channel inChannel, outChannel, errChannel;
    Tcl_Interp *interp;
    Tcl_DString argString;

    Tcl_FindExecutable(argv[0]);
    interp = Tcl_CreateInterp();
#ifdef TCL_MEM_DEBUG
    Tcl_InitMemory(interp);
#endif

    /*
     * Make command-line arguments available in the Tcl variables "argc"
     * and "argv".  If the first argument doesn't start with a "-" then
     * strip it off and use it as the name of a script file to process.
     */

    if (tclStartupScriptFileName == NULL) {
        if ((argc > 1) && (argv[1][0] != '-')) {
            tclStartupScriptFileName = argv[1];
            argc--;
            argv++;
        }
    }
    args = Tcl_Merge(argc-1, argv+1);
    Tcl_ExternalToUtfDString(NULL, args, -1, &argString);
    Tcl_SetVar(interp, "argv", Tcl_DStringValue(&argString), TCL_GLOBAL_ONLY);
    Tcl_DStringFree(&argString);
    ckfree(args);

    if (tclStartupScriptFileName == NULL) {
        Tcl_ExternalToUtfDString(NULL, argv[0], -1, &argString);
    } else {
        tclStartupScriptFileName = Tcl_ExternalToUtfDString(NULL,
                tclStartupScriptFileName, -1, &argString);
    }

    TclFormatInt(buffer, argc-1);
    Tcl_SetVar(interp, "argc", buffer, TCL_GLOBAL_ONLY);
    Tcl_SetVar(interp, "argv0", Tcl_DStringValue(&argString), TCL_GLOBAL_ONLY);

    /*
     * Set the "tcl_interactive" variable.
     */

    tty = isatty(0);
    Tcl_SetVar(interp, "tcl_interactive",
            ((tclStartupScriptFileName == NULL) && tty) ? "1" : "0",
            TCL_GLOBAL_ONLY);
    
    /*
     * Invoke application-specific initialization.
     */

     /* Register any extensions that should be registered for the
     ** executable currently being built.
     */
   ExtninitInit(interp);

   /* Set a Tcl variable to indicate the particular product
   ** we are building.  This is used in the startup message script
   ** to announce product version, and may be used other
   ** places, as well.
   */
   Tcl_SetVar(interp,
              BUILD_CONFIG_PRODUCT_NAME_VARIABLE,
              BUILD_CONFIG_STATIC_TCLSH_ALIAS,
              TCL_GLOBAL_ONLY);

   /* Set  Tcl variable to indicate the relese version of the
   ** product we are building.  This is used in the startup message script
   ** to announce product version, and may be used other
   ** places, as well.
   */
   Tcl_SetVar(interp,
              BUILD_CONFIG_PRODUCT_VERSION_VARIABLE,
              BUILD_CONFIG_RELEASE_VERSION,
              TCL_GLOBAL_ONLY);

   /* Output the introductory message to the console.
   ** The script called is generic and applies to both
   ** IjuScripter and IjuConsole.
   */
   Tcl_GlobalEval(interp, BUILD_CONFIG_StartupMessageScript);

    /*
     * If a script file was specified then just source that file
     * and quit.
     */

    if (tclStartupScriptFileName != NULL) {
        code = Tcl_EvalFile(interp, tclStartupScriptFileName);
        if (code != TCL_OK) {
            errChannel = Tcl_GetStdChannel(TCL_STDERR);
            if (errChannel) {
                /*
                 * The following statement guarantees that the errorInfo
                 * variable is set properly.
                 */

                Tcl_AddErrorInfo(interp, "");
                Tcl_WriteObj(errChannel, Tcl_GetVar2Ex(interp, "errorInfo",
                        NULL, TCL_GLOBAL_ONLY));
                Tcl_WriteChars(errChannel, "\n", 1);
            }
            exitCode = 1;
        }
        goto done;
    }
    Tcl_DStringFree(&argString);

    /*
     * We're running interactively.  Source a user-specific startup
     * file if the application specified one and if the file exists.
     */

    Tcl_SourceRCFile(interp);

    /*
     * Process commands from stdin until there's an end-of-file.  Note
     * that we need to fetch the standard channels again after every
     * eval, since they may have been changed.
     */

    commandPtr = Tcl_NewObj();
    Tcl_IncrRefCount(commandPtr);

    inChannel = Tcl_GetStdChannel(TCL_STDIN);
    outChannel = Tcl_GetStdChannel(TCL_STDOUT);
    gotPartial = 0;
    while (1) {
        if (tty) {
            Tcl_Obj *promptCmdPtr;

            promptCmdPtr = Tcl_GetVar2Ex(interp,
                    (gotPartial ? "tcl_prompt2" : "tcl_prompt1"),
                    NULL, TCL_GLOBAL_ONLY);
            if (promptCmdPtr == NULL) {
                defaultPrompt:
                if (!gotPartial && outChannel) {
                    Tcl_WriteChars(outChannel, "% ", 2);
                }
            } else {
                code = Tcl_EvalObjEx(interp, promptCmdPtr, 0);
                inChannel = Tcl_GetStdChannel(TCL_STDIN);
                outChannel = Tcl_GetStdChannel(TCL_STDOUT);
                errChannel = Tcl_GetStdChannel(TCL_STDERR);
                if (code != TCL_OK) {
                    if (errChannel) {
                        Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
                        Tcl_WriteChars(errChannel, "\n", 1);
                    }
                    Tcl_AddErrorInfo(interp,
                            "\n    (script that generates prompt)");
                    goto defaultPrompt;
                }
            }
            if (outChannel) {
                Tcl_Flush(outChannel);
            }
        }
        if (!inChannel) {
            goto done;
        }
        length = Tcl_GetsObj(inChannel, commandPtr);
        if (length < 0) {
            goto done;
        }
        if ((length == 0) && Tcl_Eof(inChannel) && (!gotPartial)) {
            goto done;
        }

        /*
         * Add the newline removed by Tcl_GetsObj back to the string.
         */

        Tcl_AppendToObj(commandPtr, "\n", 1);
        if (!TclObjCommandComplete(commandPtr)) {
            gotPartial = 1;
            continue;
        }

        gotPartial = 0;
        code = Tcl_RecordAndEvalObj(interp, commandPtr, 0);
        inChannel = Tcl_GetStdChannel(TCL_STDIN);
        outChannel = Tcl_GetStdChannel(TCL_STDOUT);
        errChannel = Tcl_GetStdChannel(TCL_STDERR);
        Tcl_DecrRefCount(commandPtr);
        commandPtr = Tcl_NewObj();
        Tcl_IncrRefCount(commandPtr);
        if (code != TCL_OK) {
            if (errChannel) {
                Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
                Tcl_WriteChars(errChannel, "\n", 1);
            }
        } else if (tty) {
            resultPtr = Tcl_GetObjResult(interp);
            Tcl_GetStringFromObj(resultPtr, &length);
            if ((length > 0) && outChannel) {
                Tcl_WriteObj(outChannel, resultPtr);
                Tcl_WriteChars(outChannel, "\n", 1);
            }
        }
#ifdef TCL_MEM_DEBUG
        if (tclMemDumpFileName != NULL) {
            Tcl_DecrRefCount(commandPtr);
            Tcl_DeleteInterp(interp);
            Tcl_Exit(0);
        }
#endif
    }

    /*
     * Rather than calling exit, invoke the "exit" command so that
     * users can replace "exit" with some other command to do additional
     * cleanup on exit.  The Tcl_Eval call should never return.
     */

    done:
    if (commandPtr != NULL) {
        Tcl_DecrRefCount(commandPtr);
    }
    sprintf(buffer, "exit %d", exitCode);
    Tcl_Eval(interp, buffer);
}


const char *TclMainCversion(void)
{   
    return ("$Header$");
}


const char *TclMainHversion(void)
{   
    return (TCLMAIN_H_VERSION);
}

/* End of tclmain.c */
1	dashley	71	/* $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 */