summaryrefslogtreecommitdiffstats
path: root/generic/tclMain.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclMain.c')
-rw-r--r--generic/tclMain.c340
1 files changed, 340 insertions, 0 deletions
diff --git a/generic/tclMain.c b/generic/tclMain.c
new file mode 100644
index 0000000..ce87636
--- /dev/null
+++ b/generic/tclMain.c
@@ -0,0 +1,340 @@
+/*
+ * 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.54 97/08/07 19:04:43
+ */
+
+#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. */
+
+#ifdef TCL_MEM_DEBUG
+static char dumpFile[100]; /* Records where to dump memory allocation
+ * information. */
+static int quitFlag = 0; /* 1 means "checkmem" command was called,
+ * 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. */
+{
+ Tcl_Obj *prompt1NamePtr = NULL;
+ Tcl_Obj *prompt2NamePtr = NULL;
+ Tcl_Obj *resultPtr;
+ Tcl_Obj *commandPtr = NULL;
+ char buffer[1000], *args, *fileName, *bytes;
+ int code, gotPartial, tty, length;
+ int exitCode = 0;
+ Tcl_Channel inChannel, outChannel, errChannel;
+
+ 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);
+ TclFormatInt(buffer, 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.
+ */
+
+ 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);
+ prompt1NamePtr = Tcl_NewStringObj("tcl_prompt1", -1);
+ Tcl_IncrRefCount(prompt1NamePtr);
+ prompt2NamePtr = Tcl_NewStringObj("tcl_prompt2", -1);
+ Tcl_IncrRefCount(prompt2NamePtr);
+
+ inChannel = Tcl_GetStdChannel(TCL_STDIN);
+ outChannel = Tcl_GetStdChannel(TCL_STDOUT);
+ gotPartial = 0;
+ while (1) {
+ if (tty) {
+ Tcl_Obj *promptCmdPtr;
+
+ promptCmdPtr = Tcl_ObjGetVar2(interp,
+ (gotPartial? prompt2NamePtr : prompt1NamePtr),
+ (Tcl_Obj *) NULL, TCL_GLOBAL_ONLY);
+ if (promptCmdPtr == NULL) {
+ defaultPrompt:
+ if (!gotPartial && outChannel) {
+ Tcl_Write(outChannel, "% ", 2);
+ }
+ } else {
+ code = Tcl_EvalObj(interp, promptCmdPtr);
+ inChannel = Tcl_GetStdChannel(TCL_STDIN);
+ outChannel = Tcl_GetStdChannel(TCL_STDOUT);
+ errChannel = Tcl_GetStdChannel(TCL_STDERR);
+ if (code != TCL_OK) {
+ if (errChannel) {
+ resultPtr = Tcl_GetObjResult(interp);
+ bytes = Tcl_GetStringFromObj(resultPtr, &length);
+ Tcl_Write(errChannel, bytes, length);
+ 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_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_SetObjLength(commandPtr, 0);
+ if (code != TCL_OK) {
+ if (errChannel) {
+ resultPtr = Tcl_GetObjResult(interp);
+ bytes = Tcl_GetStringFromObj(resultPtr, &length);
+ Tcl_Write(errChannel, bytes, length);
+ Tcl_Write(errChannel, "\n", 1);
+ }
+ } else if (tty) {
+ resultPtr = Tcl_GetObjResult(interp);
+ bytes = Tcl_GetStringFromObj(resultPtr, &length);
+ if ((length > 0) && outChannel) {
+ Tcl_Write(outChannel, bytes, length);
+ Tcl_Write(outChannel, "\n", 1);
+ }
+ }
+#ifdef TCL_MEM_DEBUG
+ if (quitFlag) {
+ Tcl_DecrRefCount(commandPtr);
+ Tcl_DecrRefCount(prompt1NamePtr);
+ Tcl_DecrRefCount(prompt2NamePtr);
+ 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);
+ }
+ if (prompt1NamePtr != NULL) {
+ Tcl_DecrRefCount(prompt1NamePtr);
+ }
+ if (prompt2NamePtr != NULL) {
+ Tcl_DecrRefCount(prompt2NamePtr);
+ }
+ 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