diff options
Diffstat (limited to 'generic/tkMain.c')
| -rw-r--r-- | generic/tkMain.c | 390 |
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); + } +} |