/*
* tkMain.c (CTk) --
*
* 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-1995 Sun Microsystems, Inc.
* Copyright (c) 1994-1995 Cleveland Clinic Foundation
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* @(#) $Id: ctk.shar,v 1.50 1996/01/15 14:47:16 andrewm Exp andrewm $
*/
#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));
extern int read _ANSI_ARGS_((int fd, char *buf, size_t size));
extern char * strrchr _ANSI_ARGS_((CONST char *string, int c));
/*
* Global variables used by the main program:
*/
static Tk_Window mainWindow; /* The main window for the application. If
* NULL then the application no longer
* exists. */
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. */
static char errorExitCmd[] = "exit 1";
/*
* Command-line options:
*/
static char *fileName = NULL;
static char *name = NULL;
static char *display = NULL;
static char *geometry = NULL;
static int rest = 0;
static Tk_ArgvInfo argTable[] = {
{"-display", TK_ARGV_STRING, (char *) NULL, (char *) &display,
"Display to use"},
{"-geometry", TK_ARGV_STRING, (char *) NULL, (char *) &geometry,
"Initial geometry for window"},
{"-name", TK_ARGV_STRING, (char *) NULL, (char *) &name,
"Name to use for application"},
{"--", TK_ARGV_REST, (char *) 1, (char *) &rest,
"Pass all remaining arguments through to script"},
{(char *) NULL, TK_ARGV_END, (char *) NULL, (char *) NULL,
(char *) NULL}
};
/*
* 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 befort starting
* to execute commands. */
{
char *args, *p, *msg, *argv0, *class;
char buf[20];
int code;
size_t length;
Tcl_Channel inChannel, outChannel, errChannel, chan;
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. Also check
* for other standard arguments, such as "-geometry", anywhere
* in the argument list.
*/
argv0 = argv[0];
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++;
}
if (Tk_ParseArgv(interp, (Tk_Window) NULL, &argc, argv, argTable, 0)
!= TCL_OK) {
fprintf(stderr, "%s\n", Tcl_GetStringResult(interp));
exit(1);
}
if (name == NULL) {
if (fileName != NULL) {
p = fileName;
} else {
p = argv[0];
}
name = strrchr(p, '/');
if (name != NULL) {
name++;
} else {
name = p;
}
}
/*
* 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 : argv0,
TCL_GLOBAL_ONLY);
/*
* If a display was specified, put it into the CTK_DISPLAY
* environment variable so that it will be available for
* any sub-processes created by us.
*/
if (display != NULL) {
Tcl_SetVar2(interp, "env", "CTK_DISPLAY", display, TCL_GLOBAL_ONLY);
}
/*
* Initialize the Tk application. If a -name option was provided,
* use it; otherwise, if a file name was provided, use the last
* element of its path as the name of the application; otherwise
* use the last element of the program name. For the application's
* class, capitalize the first letter of the name.
*/
if (name == NULL) {
p = (fileName != NULL) ? fileName : argv0;
name = strrchr(p, '/');
if (name != NULL) {
name++;
} else {
name = p;
}
}
class = (char *) ckalloc((unsigned) (strlen(name) + 1));
strcpy(class, name);
class[0] = toupper((unsigned char) class[0]);
mainWindow = Tk_CreateMainWindow(interp, display, name, class);
ckfree(class);
if (mainWindow == NULL) {
fprintf(stderr, "%s\n", Tcl_GetStringResult(interp));
exit(1);
}
/*
* Set the "tcl_interactive" variable.
*/
tty = isatty(0);
Tcl_SetVar(interp, "tcl_interactive",
((fileName == NULL) && tty) ? "1" : "0", TCL_GLOBAL_ONLY);
/*
* Set the geometry of the main window, if requested. Put the
* requested geometry into the "geometry" variable.
*/
if (geometry != NULL) {
Tcl_SetVar(interp, "geometry", geometry, TCL_GLOBAL_ONLY);
code = Tcl_VarEval(interp, "wm geometry . ", geometry, (char *) NULL);
if (code != TCL_OK) {
fprintf(stderr, "%s\n", Tcl_GetStringResult(interp));
}
}
/*
* 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, Tcl_GetStringResult(interp), -1);
Tcl_Write(errChannel, "\n", 1);
}
goto error;
}
/*
* Invoke the script specified on the command line, if any.
*/
if (fileName != NULL) {
code = Tcl_EvalFile(interp, fileName);
if (code != TCL_OK) {
goto error;
}
tty = 0;
} else {
/*
* Commands will come from standard input, so set up an event
* handler for standard input. Evaluate the .rc file, if one
* has been specified, set up an event handler for standard
* input, and print a prompt if the input device is a terminal.
*/
fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY);
if (fileName != NULL) {
Tcl_DString buffer;
char *fullName;
fullName = Tcl_TranslateFileName(interp, fileName, &buffer);
if (fullName == NULL) {
errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errChannel) {
Tcl_Write(errChannel, Tcl_GetStringResult(interp), -1);
Tcl_Write(errChannel, "\n", 1);
}
} else {
/*
* NOTE: The following relies on O_RDONLY==0.
*/
chan = Tcl_OpenFileChannel(interp, fullName, "r", 0);
if (chan != (Tcl_Channel) NULL) {
Tcl_Close(NULL, chan);
if (Tcl_EvalFile(interp, fullName) != TCL_OK) {
errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errChannel) {
Tcl_Write(errChannel, Tcl_GetStringResult(interp), -1);
Tcl_Write(errChannel, "\n", 1);
}
}
}
}
Tcl_DStringFree(&buffer);
}
if (tty &&
!Tcl_GetVar2(interp, "env", "CTK_DISPLAY", TCL_GLOBAL_ONLY)) {
/*
* Input is a terminal, and display was never set. Instead
* of reading command from stdin, pop-up a command dialog
* (since we are probably displaying to stdin/stdout).
*/
if (Tcl_Eval(interp, "ctkDialog") != TCL_OK) {
goto error;
}
} else {
Tcl_CreateFileHandler(0, TCL_READABLE, StdinProc, (ClientData) 0);
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();
/*
* Don't exit directly, but rather invoke the Tcl "exit" command.
* This gives the application the opportunity to redefine "exit"
* to do additional cleanup.
*/
Tcl_Eval(interp, "exit");
exit(1);
error:
/*
* The following statement guarantees that the errorInfo
* variable is set properly.
*/
Tcl_AddErrorInfo(interp, "");
errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errChannel) {
Tcl_Write(errChannel, Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY),
-1);
Tcl_Write(errChannel, "\n", 1);
}
Tcl_DeleteInterp(interp);
Tcl_Exit(1);
}
/*
*----------------------------------------------------------------------
*
* 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;
} else {
count = 0;
}
}
(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_CreateFileHandler(chan, 0, StdinProc, (ClientData) chan);
code = Tcl_RecordAndEval(interp, cmd, TCL_EVAL_GLOBAL);
Tcl_CreateChannelHandler(chan, TCL_READABLE, StdinProc, (ClientData) chan);
Tcl_DStringFree(&command);
if (*(Tcl_GetStringResult(interp)) != 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(Tcl_GetStringResult(interp));
}
}
/*
* 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;
promptCmd = Tcl_GetVar(interp,
partial ? "tcl_prompt2" : "tcl_prompt1", TCL_GLOBAL_ONLY);
if (promptCmd == NULL) {
defaultPrompt:
if (!partial) {
fputs("% ", stdout);
}
} else {
code = Tcl_Eval(interp, promptCmd);
if (code != TCL_OK) {
Tcl_AddErrorInfo(interp,
"\n (script that generates prompt)");
fprintf(stderr, "%s\n", Tcl_GetStringResult(interp));
goto defaultPrompt;
}
}
fflush(stdout);
}
Documentation