Import Tk 8.5.15 (as of svn r89086)
This commit is contained in:
Zachary Ware
525
generic/tkMain.c
Normal file
525
generic/tkMain.c
Normal file
@@ -0,0 +1,525 @@
|
||||
/*
|
||||
* 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 function 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-1997 Sun Microsystems, Inc.
|
||||
*
|
||||
* See the file "license.terms" for information on usage and redistribution of
|
||||
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
*/
|
||||
|
||||
#include "tclInt.h"
|
||||
#include "tkInt.h"
|
||||
#ifdef __WIN32__
|
||||
#include "tkWinInt.h"
|
||||
#include "../win/tclWinPort.h"
|
||||
#endif
|
||||
#ifdef MAC_OSX_TK
|
||||
#include "tkMacOSXInt.h"
|
||||
#endif
|
||||
|
||||
extern int TkCygwinMainEx(int, char **, Tcl_AppInitProc *, Tcl_Interp *);
|
||||
|
||||
typedef struct ThreadSpecificData {
|
||||
Tcl_Interp *interp; /* Interpreter for this thread. */
|
||||
Tcl_DString command; /* Used to assemble lines of terminal input
|
||||
* into Tcl commands. */
|
||||
Tcl_DString line; /* Used to read the next line from the
|
||||
* terminal input. */
|
||||
int tty; /* Non-zero means standard input is a
|
||||
* terminal-like device. Zero means it's a
|
||||
* file. */
|
||||
} ThreadSpecificData;
|
||||
static Tcl_ThreadDataKey dataKey;
|
||||
|
||||
/*
|
||||
* Declarations for various library functions 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: do
|
||||
* not declare "exit" here even though a declaration is really needed, because
|
||||
* it will conflict with a declaration elsewhere on some systems.
|
||||
*/
|
||||
|
||||
#if defined(__WIN32__) || defined(_WIN32)
|
||||
#define isatty WinIsTty
|
||||
static int WinIsTty(int fd) {
|
||||
HANDLE handle;
|
||||
|
||||
/*
|
||||
* 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.
|
||||
*/
|
||||
|
||||
#if !defined(STATIC_BUILD)
|
||||
if (tclStubsPtr->reserved9 && TclpIsAtty) {
|
||||
/* We are running on Cygwin */
|
||||
return TclpIsAtty(fd);
|
||||
}
|
||||
#endif
|
||||
handle = GetStdHandle(STD_INPUT_HANDLE + fd);
|
||||
|
||||
if ((handle == INVALID_HANDLE_VALUE) || (handle == 0)
|
||||
|| (GetFileType(handle) == FILE_TYPE_UNKNOWN)) {
|
||||
/*
|
||||
* If it's a bad or closed handle, then it's been connected
|
||||
* to a wish console window.
|
||||
*/
|
||||
|
||||
return 1;
|
||||
} else if (GetFileType(handle) == FILE_TYPE_CHAR) {
|
||||
/*
|
||||
* A character file handle is a tty by definition.
|
||||
*/
|
||||
|
||||
return 1;
|
||||
} else {
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
#else
|
||||
extern int isatty(int fd);
|
||||
extern char * strrchr(CONST char *string, int c);
|
||||
#endif
|
||||
|
||||
/*
|
||||
* Forward declarations for functions defined later in this file.
|
||||
*/
|
||||
|
||||
static void Prompt(Tcl_Interp *interp, int partial);
|
||||
static void StdinProc(ClientData clientData, int mask);
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
*
|
||||
* Tk_MainEx --
|
||||
*
|
||||
* Main program for Wish and most other Tk-based applications.
|
||||
*
|
||||
* Results:
|
||||
* None. This function never returns (it exits the process when it's
|
||||
* done.
|
||||
*
|
||||
* Side effects:
|
||||
* This function initializes the Tk world and then starts interpreting
|
||||
* commands; almost anything could happen, depending on the script being
|
||||
* interpreted.
|
||||
*
|
||||
*----------------------------------------------------------------------
|
||||
*/
|
||||
void
|
||||
Tk_MainEx(
|
||||
int argc, /* Number of arguments. */
|
||||
char **argv, /* Array of argument strings. */
|
||||
Tcl_AppInitProc *appInitProc,
|
||||
/* Application-specific initialization
|
||||
* function to call after most initialization
|
||||
* but before starting to execute commands. */
|
||||
Tcl_Interp *interp)
|
||||
{
|
||||
Tcl_Obj *path, *argvPtr;
|
||||
CONST char *encodingName;
|
||||
int code, nullStdin = 0;
|
||||
Tcl_Channel inChannel, outChannel;
|
||||
ThreadSpecificData *tsdPtr;
|
||||
Tcl_DString appName;
|
||||
|
||||
/*
|
||||
* Ensure that we are getting a compatible version of Tcl.
|
||||
*/
|
||||
|
||||
if (Tcl_InitStubs(interp, "8.5.0", 0) == NULL) {
|
||||
if (Tcl_InitStubs(interp, "8.1", 0) == NULL) {
|
||||
abort();
|
||||
} else {
|
||||
Tcl_Panic("%s", Tcl_GetStringResult(interp));
|
||||
}
|
||||
}
|
||||
|
||||
#if defined(__WIN32__) && !defined(STATIC_BUILD)
|
||||
|
||||
if (tclStubsPtr->reserved9) {
|
||||
/* We are running win32 Tk under Cygwin, so let's check
|
||||
* whether the env("DISPLAY") variable or the -display
|
||||
* argument is set. If so, we really want to run the
|
||||
* Tk_MainEx function of libtk8.?.dll, not this one. */
|
||||
if (Tcl_GetVar2(interp, "env", "DISPLAY", TCL_GLOBAL_ONLY)) {
|
||||
loadCygwinTk:
|
||||
if (TkCygwinMainEx(argc, argv, appInitProc, interp)) {
|
||||
/* Should never reach here. */
|
||||
return;
|
||||
}
|
||||
} else {
|
||||
int i;
|
||||
|
||||
for (i = 1; i < argc; ++i) {
|
||||
if (!strcmp(argv[i], "-display")) {
|
||||
goto loadCygwinTk;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
#endif
|
||||
|
||||
tsdPtr = (ThreadSpecificData *)
|
||||
Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
|
||||
|
||||
Tcl_FindExecutable(argv[0]);
|
||||
tsdPtr->interp = interp;
|
||||
Tcl_Preserve((ClientData) interp);
|
||||
|
||||
#if defined(__WIN32__) && !defined(STATIC_BUILD)
|
||||
if (!tclStubsPtr->reserved9) {
|
||||
/* Only initialize console when not running under cygwin */
|
||||
Tk_InitConsoleChannels(interp);
|
||||
}
|
||||
#elif defined(__WIN32__)
|
||||
Tk_InitConsoleChannels(interp);
|
||||
#endif
|
||||
|
||||
#ifdef MAC_OSX_TK
|
||||
if (Tcl_GetStartupScript(NULL) == NULL) {
|
||||
TkMacOSXDefaultStartupScript();
|
||||
}
|
||||
#endif
|
||||
|
||||
#ifdef TCL_MEM_DEBUG
|
||||
Tcl_InitMemory(interp);
|
||||
#endif
|
||||
|
||||
/*
|
||||
* If the application has not already set a startup script, parse the
|
||||
* first few command line arguments to determine the script path and
|
||||
* encoding.
|
||||
*/
|
||||
|
||||
if (NULL == Tcl_GetStartupScript(NULL)) {
|
||||
size_t length;
|
||||
|
||||
/*
|
||||
* Check whether first 3 args (argv[1] - argv[3]) look like
|
||||
* -encoding ENCODING FILENAME
|
||||
* or like
|
||||
* FILENAME
|
||||
* or like
|
||||
* -file FILENAME (ancient history support only)
|
||||
*/
|
||||
|
||||
if ((argc > 3) && (0 == strcmp("-encoding", argv[1]))
|
||||
&& ('-' != argv[3][0])) {
|
||||
Tcl_SetStartupScript(Tcl_NewStringObj(argv[3], -1), argv[2]);
|
||||
argc -= 3;
|
||||
argv += 3;
|
||||
} else if ((argc > 1) && ('-' != argv[1][0])) {
|
||||
Tcl_SetStartupScript(Tcl_NewStringObj(argv[1], -1), NULL);
|
||||
argc--;
|
||||
argv++;
|
||||
} else if ((argc > 2) && (length = strlen(argv[1]))
|
||||
&& (length > 1) && (0 == strncmp("-file", argv[1], length))
|
||||
&& ('-' != argv[2][0])) {
|
||||
Tcl_SetStartupScript(Tcl_NewStringObj(argv[2], -1), NULL);
|
||||
argc -= 2;
|
||||
argv += 2;
|
||||
}
|
||||
}
|
||||
|
||||
path = Tcl_GetStartupScript(&encodingName);
|
||||
if (NULL == path) {
|
||||
Tcl_ExternalToUtfDString(NULL, argv[0], -1, &appName);
|
||||
} else {
|
||||
int numBytes;
|
||||
CONST char *pathName = Tcl_GetStringFromObj(path, &numBytes);
|
||||
|
||||
Tcl_ExternalToUtfDString(NULL, pathName, numBytes, &appName);
|
||||
path = Tcl_NewStringObj(Tcl_DStringValue(&appName), -1);
|
||||
Tcl_SetStartupScript(path, encodingName);
|
||||
}
|
||||
Tcl_SetVar(interp, "argv0", Tcl_DStringValue(&appName), TCL_GLOBAL_ONLY);
|
||||
Tcl_DStringFree(&appName);
|
||||
argc--;
|
||||
argv++;
|
||||
|
||||
Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewIntObj(argc), TCL_GLOBAL_ONLY);
|
||||
|
||||
argvPtr = Tcl_NewListObj(0, NULL);
|
||||
while (argc--) {
|
||||
Tcl_DString ds;
|
||||
|
||||
Tcl_ExternalToUtfDString(NULL, *argv++, -1, &ds);
|
||||
Tcl_ListObjAppendElement(NULL, argvPtr, Tcl_NewStringObj(
|
||||
Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)));
|
||||
Tcl_DStringFree(&ds);
|
||||
}
|
||||
Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY);
|
||||
|
||||
/*
|
||||
* Set the "tcl_interactive" variable.
|
||||
*/
|
||||
|
||||
tsdPtr->tty = isatty(0);
|
||||
|
||||
#if defined(MAC_OSX_TK)
|
||||
/*
|
||||
* On TkAqua, if we don't have a TTY and stdin is a special character file
|
||||
* of length 0, (e.g. /dev/null, which is what Finder sets when double
|
||||
* clicking Wish) then use the GUI console.
|
||||
*/
|
||||
|
||||
if (!tsdPtr->tty) {
|
||||
struct stat st;
|
||||
|
||||
nullStdin = fstat(0, &st) || (S_ISCHR(st.st_mode) && !st.st_blocks);
|
||||
}
|
||||
#endif
|
||||
Tcl_SetVar(interp, "tcl_interactive",
|
||||
((path == NULL) && (tsdPtr->tty || nullStdin)) ? "1" : "0",
|
||||
TCL_GLOBAL_ONLY);
|
||||
|
||||
/*
|
||||
* Invoke application-specific initialization.
|
||||
*/
|
||||
|
||||
if ((*appInitProc)(interp) != TCL_OK) {
|
||||
TkpDisplayWarning(Tcl_GetStringResult(interp),
|
||||
"Application initialization failed");
|
||||
}
|
||||
|
||||
/*
|
||||
* Invoke the script specified on the command line, if any. Must fetch it
|
||||
* again, as the appInitProc might have reset it.
|
||||
*/
|
||||
|
||||
path = Tcl_GetStartupScript(&encodingName);
|
||||
if (path != NULL) {
|
||||
Tcl_ResetResult(interp);
|
||||
code = Tcl_FSEvalFileEx(interp, path, encodingName);
|
||||
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);
|
||||
}
|
||||
tsdPtr->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 (tsdPtr->tty) {
|
||||
Prompt(interp, 0);
|
||||
}
|
||||
}
|
||||
|
||||
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
|
||||
if (outChannel) {
|
||||
Tcl_Flush(outChannel);
|
||||
}
|
||||
Tcl_DStringInit(&tsdPtr->command);
|
||||
Tcl_DStringInit(&tsdPtr->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_Release((ClientData) interp);
|
||||
Tcl_SetStartupScript(NULL, NULL);
|
||||
Tcl_Exit(0);
|
||||
}
|
||||
|
||||
/*
|
||||
*----------------------------------------------------------------------
|
||||
*
|
||||
* StdinProc --
|
||||
*
|
||||
* This function 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 clientData, /* Not used. */
|
||||
int mask) /* Not used. */
|
||||
{
|
||||
static int gotPartial = 0;
|
||||
char *cmd;
|
||||
int code, count;
|
||||
Tcl_Channel chan = (Tcl_Channel) clientData;
|
||||
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
|
||||
Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
|
||||
Tcl_Interp *interp = tsdPtr->interp;
|
||||
|
||||
count = Tcl_Gets(chan, &tsdPtr->line);
|
||||
|
||||
if (count < 0 && !gotPartial) {
|
||||
if (tsdPtr->tty) {
|
||||
Tcl_Exit(0);
|
||||
} else {
|
||||
Tcl_DeleteChannelHandler(chan, StdinProc, (ClientData) chan);
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
(void) Tcl_DStringAppend(&tsdPtr->command, Tcl_DStringValue(
|
||||
&tsdPtr->line), -1);
|
||||
cmd = Tcl_DStringAppend(&tsdPtr->command, "\n", -1);
|
||||
Tcl_DStringFree(&tsdPtr->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(&tsdPtr->command);
|
||||
if (Tcl_GetStringResult(interp)[0] != '\0') {
|
||||
if ((code != TCL_OK) || (tsdPtr->tty)) {
|
||||
chan = Tcl_GetStdChannel(TCL_STDOUT);
|
||||
if (chan) {
|
||||
Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
|
||||
Tcl_WriteChars(chan, "\n", 1);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
/*
|
||||
* Output a prompt.
|
||||
*/
|
||||
|
||||
prompt:
|
||||
if (tsdPtr->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(
|
||||
Tcl_Interp *interp, /* Interpreter to use for prompting. */
|
||||
int partial) /* Non-zero means there already exists a
|
||||
* partial command, so use the secondary
|
||||
* prompt. */
|
||||
{
|
||||
Tcl_Obj *promptCmd;
|
||||
int code;
|
||||
Tcl_Channel outChannel, errChannel;
|
||||
|
||||
promptCmd = Tcl_GetVar2Ex(interp,
|
||||
partial ? "tcl_prompt2" : "tcl_prompt1", NULL, 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_WriteChars(outChannel, "% ", 2);
|
||||
}
|
||||
}
|
||||
} else {
|
||||
code = Tcl_EvalObjEx(interp, promptCmd, TCL_EVAL_GLOBAL);
|
||||
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_WriteObj(errChannel, Tcl_GetObjResult(interp));
|
||||
Tcl_WriteChars(errChannel, "\n", 1);
|
||||
}
|
||||
goto defaultPrompt;
|
||||
}
|
||||
}
|
||||
outChannel = Tcl_GetChannel(interp, "stdout", NULL);
|
||||
if (outChannel != (Tcl_Channel) NULL) {
|
||||
Tcl_Flush(outChannel);
|
||||
}
|
||||
}
|
||||
|
||||
/*
|
||||
* Local Variables:
|
||||
* mode: c
|
||||
* c-basic-offset: 4
|
||||
* fill-column: 78
|
||||
* End:
|
||||
*/
|
||||
Reference in New Issue
Block a user