Initial revision

1 files changed, 390 insertions, 0 deletions

diff --git a/generic/tkMain.c b/generic/tkMain.c
new file mode 100644
index 0000000..ed823bd
--- /dev/null
+++ b/generic/tkMain.c
@@ -0,0 +1,390 @@
+/* 
+ * tkMain.c --
+ *
+ *	This file contains a generic main program for Tk-based applications.
+ *	It can be used as-is for many applications, just by supplying a
+ *	different appInitProc procedure for each specific application.
+ *	Or, it can be used as a template for creating new main programs
+ *	for Tk applications.
+ *
+ * Copyright (c) 1990-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: @(#) tkMain.c 1.154 97/08/29 10:40:43
+ */
+
+#include <ctype.h>
+#include <stdio.h>
+#include <string.h>
+#include <tcl.h>
+#include <tk.h>
+#ifdef NO_STDLIB_H
+#   include "../compat/stdlib.h"
+#else
+#   include <stdlib.h>
+#endif
+
+/*
+ * Declarations for various library procedures and variables (don't want
+ * to include tkInt.h or tkPort.h here, because people might copy this
+ * file out of the Tk source directory to make their own modified versions).
+ * Note: don't declare "exit" here even though a declaration is really
+ * needed, because it will conflict with a declaration elsewhere on
+ * some systems.
+ */
+
+extern int		isatty _ANSI_ARGS_((int fd));
+#if !defined(__WIN32__) && !defined(_WIN32)
+extern char *		strrchr _ANSI_ARGS_((CONST char *string, int c));
+#endif
+extern void		TkpDisplayWarning _ANSI_ARGS_((char *msg,
+			    char *title));
+
+/*
+ * Global variables used by the main program:
+ */
+
+static Tcl_Interp *interp;	/* Interpreter for this application. */
+static Tcl_DString command;	/* Used to assemble lines of terminal input
+				 * into Tcl commands. */
+static Tcl_DString line;	/* Used to read the next line from the
+                                 * terminal input. */
+static int tty;			/* Non-zero means standard input is a
+				 * terminal-like device.  Zero means it's
+				 * a file. */
+
+/*
+ * Forward declarations for procedures defined later in this file.
+ */
+
+static void		Prompt _ANSI_ARGS_((Tcl_Interp *interp, int partial));
+static void		StdinProc _ANSI_ARGS_((ClientData clientData,
+			    int mask));
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tk_Main --
+ *
+ *	Main program for Wish and most other Tk-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
+Tk_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 *args, *fileName;
+    char buf[20];
+    int code;
+    size_t length;
+    Tcl_Channel inChannel, outChannel;
+
+    Tcl_FindExecutable(argv[0]);
+    interp = Tcl_CreateInterp();
+#ifdef TCL_MEM_DEBUG
+    Tcl_InitMemory(interp);
+#endif
+
+    /*
+     * Parse command-line arguments.  A leading "-file" argument is
+     * ignored (a historical relic from the distant past).  If the
+     * next 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) {
+	length = strlen(argv[1]);
+	if ((length >= 2) && (strncmp(argv[1], "-file", length) == 0)) {
+	    argc--;
+	    argv++;
+	}
+    }
+    if ((argc > 1) && (argv[1][0] != '-')) {
+	fileName = argv[1];
+	argc--;
+	argv++;
+    }
+
+    /*
+     * Make command-line arguments available in the Tcl variables "argc"
+     * and "argv".
+     */
+
+    args = Tcl_Merge(argc-1, argv+1);
+    Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY);
+    ckfree(args);
+    sprintf(buf, "%d", argc-1);
+    Tcl_SetVar(interp, "argc", buf, TCL_GLOBAL_ONLY);
+    Tcl_SetVar(interp, "argv0", (fileName != NULL) ? fileName : argv[0],
+	    TCL_GLOBAL_ONLY);
+
+    /*
+     * Set the "tcl_interactive" variable.
+     */
+
+    /*
+     * For now, under Windows, we assume we are not running as a console mode
+     * app, so we need to use the GUI console.  In order to enable this, we
+     * always claim to be running on a tty.  This probably isn't the right
+     * way to do it.
+     */
+
+#ifdef __WIN32__
+    tty = 1;
+#else
+    tty = isatty(0);
+#endif
+    Tcl_SetVar(interp, "tcl_interactive",
+	    ((fileName == NULL) && tty) ? "1" : "0", TCL_GLOBAL_ONLY);
+
+    /*
+     * Invoke application-specific initialization.
+     */
+
+    if ((*appInitProc)(interp) != TCL_OK) {
+	TkpDisplayWarning(interp->result, "Application initialization failed");
+    }
+
+    /*
+     * Invoke the script specified on the command line, if any.
+     */
+
+    if (fileName != NULL) {
+	code = Tcl_EvalFile(interp, fileName);
+	if (code != TCL_OK) {
+	    /*
+	     * The following statement guarantees that the errorInfo
+	     * variable is set properly.
+	     */
+
+	    Tcl_AddErrorInfo(interp, "");
+	    TkpDisplayWarning(Tcl_GetVar(interp, "errorInfo",
+		    TCL_GLOBAL_ONLY), "Error in startup script");
+	    Tcl_DeleteInterp(interp);
+	    Tcl_Exit(1);
+	}
+	tty = 0;
+    } else {
+
+	/*
+	 * Evaluate the .rc file, if one has been specified.
+	 */
+
+	Tcl_SourceRCFile(interp);
+
+	/*
+	 * Establish a channel handler for stdin.
+	 */
+
+	inChannel = Tcl_GetStdChannel(TCL_STDIN);
+	if (inChannel) {
+	    Tcl_CreateChannelHandler(inChannel, TCL_READABLE, StdinProc,
+		    (ClientData) inChannel);
+	}
+	if (tty) {
+	    Prompt(interp, 0);
+	}
+    }
+
+    outChannel = Tcl_GetStdChannel(TCL_STDOUT);
+    if (outChannel) {
+	Tcl_Flush(outChannel);
+    }
+    Tcl_DStringInit(&command);
+    Tcl_DStringInit(&line);
+    Tcl_ResetResult(interp);
+
+    /*
+     * Loop infinitely, waiting for commands to execute.  When there
+     * are no windows left, Tk_MainLoop returns and we exit.
+     */
+
+    Tk_MainLoop();
+    Tcl_DeleteInterp(interp);
+    Tcl_Exit(0);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * StdinProc --
+ *
+ *	This procedure is invoked by the event dispatcher whenever
+ *	standard input becomes readable.  It grabs the next line of
+ *	input characters, adds them to a command being assembled, and
+ *	executes the command if it's complete.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Could be almost arbitrary, depending on the command that's
+ *	typed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+    /* ARGSUSED */
+static void
+StdinProc(clientData, mask)
+    ClientData clientData;		/* Not used. */
+    int mask;				/* Not used. */
+{
+    static int gotPartial = 0;
+    char *cmd;
+    int code, count;
+    Tcl_Channel chan = (Tcl_Channel) clientData;
+
+    count = Tcl_Gets(chan, &line);
+
+    if (count < 0) {
+	if (!gotPartial) {
+	    if (tty) {
+		Tcl_Exit(0);
+	    } else {
+		Tcl_DeleteChannelHandler(chan, StdinProc, (ClientData) chan);
+	    }
+	    return;
+	} 
+    }
+
+    (void) Tcl_DStringAppend(&command, Tcl_DStringValue(&line), -1);
+    cmd = Tcl_DStringAppend(&command, "\n", -1);
+    Tcl_DStringFree(&line);
+    if (!Tcl_CommandComplete(cmd)) {
+        gotPartial = 1;
+        goto prompt;
+    }
+    gotPartial = 0;
+
+    /*
+     * Disable the stdin channel handler while evaluating the command;
+     * otherwise if the command re-enters the event loop we might
+     * process commands from stdin before the current command is
+     * finished.  Among other things, this will trash the text of the
+     * command being evaluated.
+     */
+
+    Tcl_CreateChannelHandler(chan, 0, StdinProc, (ClientData) chan);
+    code = Tcl_RecordAndEval(interp, cmd, TCL_EVAL_GLOBAL);
+    
+    chan = Tcl_GetStdChannel(TCL_STDIN);
+    if (chan) {
+	Tcl_CreateChannelHandler(chan, TCL_READABLE, StdinProc,
+		(ClientData) chan);
+    }
+    Tcl_DStringFree(&command);
+    if (*interp->result != 0) {
+	if ((code != TCL_OK) || (tty)) {
+	    /*
+	     * The statement below used to call "printf", but that resulted
+	     * in core dumps under Solaris 2.3 if the result was very long.
+             *
+             * NOTE: This probably will not work under Windows either.
+	     */
+
+	    puts(interp->result);
+	}
+    }
+
+    /*
+     * Output a prompt.
+     */
+
+    prompt:
+    if (tty) {
+	Prompt(interp, gotPartial);
+    }
+    Tcl_ResetResult(interp);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Prompt --
+ *
+ *	Issue a prompt on standard output, or invoke a script
+ *	to issue the prompt.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	A prompt gets output, and a Tcl script may be evaluated
+ *	in interp.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+Prompt(interp, partial)
+    Tcl_Interp *interp;			/* Interpreter to use for prompting. */
+    int partial;			/* Non-zero means there already
+					 * exists a partial command, so use
+					 * the secondary prompt. */
+{
+    char *promptCmd;
+    int code;
+    Tcl_Channel outChannel, errChannel;
+
+    promptCmd = Tcl_GetVar(interp,
+	partial ? "tcl_prompt2" : "tcl_prompt1", TCL_GLOBAL_ONLY);
+    if (promptCmd == NULL) {
+defaultPrompt:
+	if (!partial) {
+
+            /*
+             * We must check that outChannel is a real channel - it
+             * is possible that someone has transferred stdout out of
+             * this interpreter with "interp transfer".
+             */
+
+	    outChannel = Tcl_GetChannel(interp, "stdout", NULL);
+            if (outChannel != (Tcl_Channel) NULL) {
+                Tcl_Write(outChannel, "% ", 2);
+            }
+	}
+    } else {
+	code = Tcl_Eval(interp, promptCmd);
+	if (code != TCL_OK) {
+	    Tcl_AddErrorInfo(interp,
+		    "\n    (script that generates prompt)");
+            /*
+             * We must check that errChannel is a real channel - it
+             * is possible that someone has transferred stderr out of
+             * this interpreter with "interp transfer".
+             */
+            
+	    errChannel = Tcl_GetChannel(interp, "stderr", NULL);
+            if (errChannel != (Tcl_Channel) NULL) {
+                Tcl_Write(errChannel, interp->result, -1);
+                Tcl_Write(errChannel, "\n", 1);
+            }
+	    goto defaultPrompt;
+	}
+    }
+    outChannel = Tcl_GetChannel(interp, "stdout", NULL);
+    if (outChannel != (Tcl_Channel) NULL) {
+        Tcl_Flush(outChannel);
+    }
+}