diff options
Diffstat (limited to 'contrib/tcl/generic/tclMain.c')
| -rw-r--r-- | contrib/tcl/generic/tclMain.c | 347 |
1 files changed, 347 insertions, 0 deletions
diff --git a/contrib/tcl/generic/tclMain.c b/contrib/tcl/generic/tclMain.c new file mode 100644 index 0000000..d7b029d --- /dev/null +++ b/contrib/tcl/generic/tclMain.c @@ -0,0 +1,347 @@ +/* + * 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-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclMain.c 1.50 96/04/10 16:40:57 + */ + +#include "tcl.h" +#include "tclInt.h" + +/* + * 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 Tcl_Interp *interp; /* Interpreter for application. */ +static Tcl_DString command; /* Used to buffer incomplete commands being + * read from stdin. */ +#ifdef TCL_MEM_DEBUG +static char dumpFile[100]; /* Records where to dump memory allocation + * information. */ +static int quitFlag = 0; /* 1 means the "checkmem" command was + * invoked, so the application should quit + * and dump memory allocation information. */ +#endif + +/* + * Forward references for procedures defined later in this file: + */ + +#ifdef TCL_MEM_DEBUG +static int CheckmemCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char *argv[])); +#endif + +/* + *---------------------------------------------------------------------- + * + * 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 Tk 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. */ +{ + char buffer[1000], *cmd, *args, *fileName; + int code, gotPartial, tty, length; + int exitCode = 0; + Tcl_Channel inChannel, outChannel, errChannel; + Tcl_DString temp; + + Tcl_FindExecutable(argv[0]); + interp = Tcl_CreateInterp(); +#ifdef TCL_MEM_DEBUG + Tcl_InitMemory(interp); + Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); +#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. + */ + + fileName = NULL; + if ((argc > 1) && (argv[1][0] != '-')) { + fileName = argv[1]; + argc--; + argv++; + } + args = Tcl_Merge(argc-1, argv+1); + Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY); + ckfree(args); + sprintf(buffer, "%d", argc-1); + Tcl_SetVar(interp, "argc", buffer, TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "argv0", (fileName != NULL) ? fileName : argv[0], + TCL_GLOBAL_ONLY); + + /* + * Set the "tcl_interactive" variable. + */ + + tty = isatty(0); + Tcl_SetVar(interp, "tcl_interactive", + ((fileName == NULL) && tty) ? "1" : "0", TCL_GLOBAL_ONLY); + + /* + * Invoke application-specific initialization. + */ + + if ((*appInitProc)(interp) != TCL_OK) { + errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (errChannel) { + Tcl_Write(errChannel, + "application-specific initialization failed: ", -1); + Tcl_Write(errChannel, interp->result, -1); + Tcl_Write(errChannel, "\n", 1); + } + } + + /* + * If a script file was specified then just source that file + * and quit. + */ + + if (fileName != NULL) { + code = Tcl_EvalFile(interp, fileName); + 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_Write(errChannel, + Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY), -1); + Tcl_Write(errChannel, "\n", 1); + } + exitCode = 1; + } + goto done; + } + + /* + * We're running interactively. Source a user-specific startup + * file if the application specified one and if the file exists. + */ + + fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY); + + if (fileName != NULL) { + Tcl_Channel c; + char *fullName; + + Tcl_DStringInit(&temp); + fullName = Tcl_TranslateFileName(interp, fileName, &temp); + if (fullName == NULL) { + errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (errChannel) { + Tcl_Write(errChannel, interp->result, -1); + Tcl_Write(errChannel, "\n", 1); + } + } else { + + /* + * Test for the existence of the rc file before trying to read it. + */ + + c = Tcl_OpenFileChannel(NULL, fullName, "r", 0); + if (c != (Tcl_Channel) NULL) { + Tcl_Close(NULL, c); + if (Tcl_EvalFile(interp, fullName) != TCL_OK) { + errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (errChannel) { + Tcl_Write(errChannel, interp->result, -1); + Tcl_Write(errChannel, "\n", 1); + } + } + } + } + Tcl_DStringFree(&temp); + } + + /* + * 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. + */ + + gotPartial = 0; + Tcl_DStringInit(&command); + inChannel = Tcl_GetStdChannel(TCL_STDIN); + outChannel = Tcl_GetStdChannel(TCL_STDOUT); + while (1) { + if (tty) { + char *promptCmd; + + promptCmd = Tcl_GetVar(interp, + gotPartial ? "tcl_prompt2" : "tcl_prompt1", TCL_GLOBAL_ONLY); + if (promptCmd == NULL) { +defaultPrompt: + if (!gotPartial && outChannel) { + Tcl_Write(outChannel, "% ", 2); + } + } else { + code = Tcl_Eval(interp, promptCmd); + inChannel = Tcl_GetStdChannel(TCL_STDIN); + outChannel = Tcl_GetStdChannel(TCL_STDOUT); + errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (code != TCL_OK) { + if (errChannel) { + Tcl_Write(errChannel, interp->result, -1); + Tcl_Write(errChannel, "\n", 1); + } + Tcl_AddErrorInfo(interp, + "\n (script that generates prompt)"); + goto defaultPrompt; + } + } + if (outChannel) { + Tcl_Flush(outChannel); + } + } + if (!inChannel) { + goto done; + } + length = Tcl_Gets(inChannel, &command); + if (length < 0) { + goto done; + } + if ((length == 0) && Tcl_Eof(inChannel) && (!gotPartial)) { + goto done; + } + + /* + * Add the newline removed by Tcl_Gets back to the string. + */ + + (void) Tcl_DStringAppend(&command, "\n", -1); + + cmd = Tcl_DStringValue(&command); + if (!Tcl_CommandComplete(cmd)) { + gotPartial = 1; + continue; + } + + gotPartial = 0; + code = Tcl_RecordAndEval(interp, cmd, 0); + inChannel = Tcl_GetStdChannel(TCL_STDIN); + outChannel = Tcl_GetStdChannel(TCL_STDOUT); + errChannel = Tcl_GetStdChannel(TCL_STDERR); + Tcl_DStringFree(&command); + if (code != TCL_OK) { + if (errChannel) { + Tcl_Write(errChannel, interp->result, -1); + Tcl_Write(errChannel, "\n", 1); + } + } else if (tty && (*interp->result != 0)) { + if (outChannel) { + Tcl_Write(outChannel, interp->result, -1); + Tcl_Write(outChannel, "\n", 1); + } + } +#ifdef TCL_MEM_DEBUG + if (quitFlag) { + 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: + sprintf(buffer, "exit %d", exitCode); + Tcl_Eval(interp, buffer); +} + +/* + *---------------------------------------------------------------------- + * + * CheckmemCmd -- + * + * This is the command procedure for the "checkmem" command, which + * causes the application to exit after printing information about + * memory usage to the file passed to this command as its first + * argument. + * + * Results: + * Returns a standard Tcl completion code. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +#ifdef TCL_MEM_DEBUG + + /* ARGSUSED */ +static int +CheckmemCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Interpreter for evaluation. */ + int argc; /* Number of arguments. */ + char *argv[]; /* String values of arguments. */ +{ + extern char *tclMemDumpFileName; + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " fileName\"", (char *) NULL); + return TCL_ERROR; + } + strcpy(dumpFile, argv[1]); + tclMemDumpFileName = dumpFile; + quitFlag = 1; + return TCL_OK; +} +#endif |
