348 lines
9.4 KiB
C
348 lines
9.4 KiB
C
|
/*
|
|||
|
* 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.50 96/04/10 16:40:57
|
|||
|
*/
|
|||
|
|
|||
|
#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. */
|
|||
|
static Tcl_DString command; /* Used to buffer incomplete commands being
|
|||
|
* read from stdin. */
|
|||
|
#ifdef TCL_MEM_DEBUG
|
|||
|
static char dumpFile[100]; /* Records where to dump memory allocation
|
|||
|
* information. */
|
|||
|
static int quitFlag = 0; /* 1 means the "checkmem" command was
|
|||
|
* invoked, 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. */
|
|||
|
{
|
|||
|
char buffer[1000], *cmd, *args, *fileName;
|
|||
|
int code, gotPartial, tty, length;
|
|||
|
int exitCode = 0;
|
|||
|
Tcl_Channel inChannel, outChannel, errChannel;
|
|||
|
Tcl_DString temp;
|
|||
|
|
|||
|
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);
|
|||
|
sprintf(buffer, "%d", 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.
|
|||
|
*/
|
|||
|
|
|||
|
fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY);
|
|||
|
|
|||
|
if (fileName != NULL) {
|
|||
|
Tcl_Channel c;
|
|||
|
char *fullName;
|
|||
|
|
|||
|
Tcl_DStringInit(&temp);
|
|||
|
fullName = Tcl_TranslateFileName(interp, fileName, &temp);
|
|||
|
if (fullName == NULL) {
|
|||
|
errChannel = Tcl_GetStdChannel(TCL_STDERR);
|
|||
|
if (errChannel) {
|
|||
|
Tcl_Write(errChannel, interp->result, -1);
|
|||
|
Tcl_Write(errChannel, "\n", 1);
|
|||
|
}
|
|||
|
} else {
|
|||
|
|
|||
|
/*
|
|||
|
* Test for the existence of the rc file before trying to read it.
|
|||
|
*/
|
|||
|
|
|||
|
c = Tcl_OpenFileChannel(NULL, fullName, "r", 0);
|
|||
|
if (c != (Tcl_Channel) NULL) {
|
|||
|
Tcl_Close(NULL, c);
|
|||
|
if (Tcl_EvalFile(interp, fullName) != TCL_OK) {
|
|||
|
errChannel = Tcl_GetStdChannel(TCL_STDERR);
|
|||
|
if (errChannel) {
|
|||
|
Tcl_Write(errChannel, interp->result, -1);
|
|||
|
Tcl_Write(errChannel, "\n", 1);
|
|||
|
}
|
|||
|
}
|
|||
|
}
|
|||
|
}
|
|||
|
Tcl_DStringFree(&temp);
|
|||
|
}
|
|||
|
|
|||
|
/*
|
|||
|
* 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.
|
|||
|
*/
|
|||
|
|
|||
|
gotPartial = 0;
|
|||
|
Tcl_DStringInit(&command);
|
|||
|
inChannel = Tcl_GetStdChannel(TCL_STDIN);
|
|||
|
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
|
|||
|
while (1) {
|
|||
|
if (tty) {
|
|||
|
char *promptCmd;
|
|||
|
|
|||
|
promptCmd = Tcl_GetVar(interp,
|
|||
|
gotPartial ? "tcl_prompt2" : "tcl_prompt1", TCL_GLOBAL_ONLY);
|
|||
|
if (promptCmd == NULL) {
|
|||
|
defaultPrompt:
|
|||
|
if (!gotPartial && outChannel) {
|
|||
|
Tcl_Write(outChannel, "% ", 2);
|
|||
|
}
|
|||
|
} else {
|
|||
|
code = Tcl_Eval(interp, promptCmd);
|
|||
|
inChannel = Tcl_GetStdChannel(TCL_STDIN);
|
|||
|
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
|
|||
|
errChannel = Tcl_GetStdChannel(TCL_STDERR);
|
|||
|
if (code != TCL_OK) {
|
|||
|
if (errChannel) {
|
|||
|
Tcl_Write(errChannel, interp->result, -1);
|
|||
|
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_Gets(inChannel, &command);
|
|||
|
if (length < 0) {
|
|||
|
goto done;
|
|||
|
}
|
|||
|
if ((length == 0) && Tcl_Eof(inChannel) && (!gotPartial)) {
|
|||
|
goto done;
|
|||
|
}
|
|||
|
|
|||
|
/*
|
|||
|
* Add the newline removed by Tcl_Gets back to the string.
|
|||
|
*/
|
|||
|
|
|||
|
(void) Tcl_DStringAppend(&command, "\n", -1);
|
|||
|
|
|||
|
cmd = Tcl_DStringValue(&command);
|
|||
|
if (!Tcl_CommandComplete(cmd)) {
|
|||
|
gotPartial = 1;
|
|||
|
continue;
|
|||
|
}
|
|||
|
|
|||
|
gotPartial = 0;
|
|||
|
code = Tcl_RecordAndEval(interp, cmd, 0);
|
|||
|
inChannel = Tcl_GetStdChannel(TCL_STDIN);
|
|||
|
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
|
|||
|
errChannel = Tcl_GetStdChannel(TCL_STDERR);
|
|||
|
Tcl_DStringFree(&command);
|
|||
|
if (code != TCL_OK) {
|
|||
|
if (errChannel) {
|
|||
|
Tcl_Write(errChannel, interp->result, -1);
|
|||
|
Tcl_Write(errChannel, "\n", 1);
|
|||
|
}
|
|||
|
} else if (tty && (*interp->result != 0)) {
|
|||
|
if (outChannel) {
|
|||
|
Tcl_Write(outChannel, interp->result, -1);
|
|||
|
Tcl_Write(outChannel, "\n", 1);
|
|||
|
}
|
|||
|
}
|
|||
|
#ifdef TCL_MEM_DEBUG
|
|||
|
if (quitFlag) {
|
|||
|
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:
|
|||
|
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
|