297 lines
8.0 KiB
C
297 lines
8.0 KiB
C
/*
|
||
* main.c --
|
||
*
|
||
* Main program for Tcl shells and other Tcl-based applications.
|
||
*
|
||
* Copyright (c) 1988-1993 The Regents of the University of California.
|
||
* All rights reserved.
|
||
*
|
||
* Permission is hereby granted, without written agreement and without
|
||
* license or royalty fees, to use, copy, modify, and distribute this
|
||
* software and its documentation for any purpose, provided that the
|
||
* above copyright notice and the following two paragraphs appear in
|
||
* all copies of this software.
|
||
*
|
||
* IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
|
||
* DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
|
||
* OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
|
||
* CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||
*
|
||
* THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
|
||
* INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
|
||
* AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
|
||
* ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
|
||
* PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
|
||
*/
|
||
|
||
#ifndef lint
|
||
static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclMain.c,v 1.12 93/11/11 09:35:10 ouster Exp $ SPRITE (Berkeley)";
|
||
#endif
|
||
|
||
#include <stdio.h>
|
||
#include <tcl.h>
|
||
#include <errno.h>
|
||
|
||
/*
|
||
* Declarations for various library procedures and variables (don't want
|
||
* to include tclUnix.h here, because people might copy this file out of
|
||
* the Tcl source directory to make their own modified versions).
|
||
*/
|
||
|
||
extern int errno;
|
||
extern void exit _ANSI_ARGS_((int status));
|
||
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. */
|
||
char *tcl_RcFileName = NULL; /* Name of a user-specific startup script
|
||
* to source if the application is being run
|
||
* interactively (e.g. "~/.tclshrc"). Set
|
||
* by Tcl_AppInit. NULL means don't source
|
||
* anything ever. */
|
||
#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:
|
||
*/
|
||
|
||
static int CheckmemCmd _ANSI_ARGS_((ClientData clientData,
|
||
Tcl_Interp *interp, int argc, char *argv[]));
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* main --
|
||
*
|
||
* This is the main program for a Tcl-based shell that reads
|
||
* Tcl commands from standard input.
|
||
*
|
||
* Results:
|
||
* None.
|
||
*
|
||
* Side effects:
|
||
* Can be almost arbitrary, depending on what the Tcl commands do.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
int
|
||
main(argc, argv)
|
||
int argc; /* Number of arguments. */
|
||
char **argv; /* Array of argument strings. */
|
||
{
|
||
char buffer[1000], *cmd, *args, *fileName;
|
||
int code, gotPartial, tty;
|
||
int exitCode = 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 (Tcl_AppInit(interp) != TCL_OK) {
|
||
fprintf(stderr, "Tcl_AppInit failed: %s\n", interp->result);
|
||
}
|
||
|
||
/*
|
||
* 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) {
|
||
fprintf(stderr, "%s\n", interp->result);
|
||
exitCode = 1;
|
||
}
|
||
goto done;
|
||
}
|
||
|
||
/*
|
||
* We're running interactively. Source a user-specific startup
|
||
* file if Tcl_AppInit specified one and if the file exists.
|
||
*/
|
||
|
||
if (tcl_RcFileName != NULL) {
|
||
Tcl_DString buffer;
|
||
char *fullName;
|
||
FILE *f;
|
||
|
||
fullName = Tcl_TildeSubst(interp, tcl_RcFileName, &buffer);
|
||
if (fullName == NULL) {
|
||
fprintf(stderr, "%s\n", interp->result);
|
||
} else {
|
||
f = fopen(fullName, "r");
|
||
if (f != NULL) {
|
||
code = Tcl_EvalFile(interp, fullName);
|
||
if (code != TCL_OK) {
|
||
fprintf(stderr, "%s\n", interp->result);
|
||
}
|
||
fclose(f);
|
||
}
|
||
}
|
||
Tcl_DStringFree(&buffer);
|
||
}
|
||
|
||
/*
|
||
* Process commands from stdin until there's an end-of-file.
|
||
*/
|
||
|
||
gotPartial = 0;
|
||
Tcl_DStringInit(&command);
|
||
while (1) {
|
||
clearerr(stdin);
|
||
if (tty) {
|
||
char *promptCmd;
|
||
|
||
promptCmd = Tcl_GetVar(interp,
|
||
gotPartial ? "tcl_prompt2" : "tcl_prompt1", TCL_GLOBAL_ONLY);
|
||
if (promptCmd == NULL) {
|
||
defaultPrompt:
|
||
if (!gotPartial) {
|
||
fputs("% ", stdout);
|
||
}
|
||
} else {
|
||
code = Tcl_Eval(interp, promptCmd);
|
||
if (code != TCL_OK) {
|
||
fprintf(stderr, "%s\n", interp->result);
|
||
Tcl_AddErrorInfo(interp,
|
||
"\n (script that generates prompt)");
|
||
goto defaultPrompt;
|
||
}
|
||
}
|
||
fflush(stdout);
|
||
}
|
||
if (fgets(buffer, 1000, stdin) == NULL) {
|
||
if (ferror(stdin)) {
|
||
if (errno == EINTR) {
|
||
if (tcl_AsyncReady) {
|
||
(void) Tcl_AsyncInvoke((Tcl_Interp *) NULL, 0);
|
||
}
|
||
clearerr(stdin);
|
||
} else {
|
||
goto done;
|
||
}
|
||
} else {
|
||
if (!gotPartial) {
|
||
goto done;
|
||
}
|
||
}
|
||
buffer[0] = 0;
|
||
}
|
||
cmd = Tcl_DStringAppend(&command, buffer, -1);
|
||
if ((buffer[0] != 0) && !Tcl_CommandComplete(cmd)) {
|
||
gotPartial = 1;
|
||
continue;
|
||
}
|
||
|
||
gotPartial = 0;
|
||
code = Tcl_RecordAndEval(interp, cmd, 0);
|
||
Tcl_DStringFree(&command);
|
||
if (code != TCL_OK) {
|
||
fprintf(stderr, "%s\n", interp->result);
|
||
} else if (tty && (*interp->result != 0)) {
|
||
printf("%s\n", interp->result);
|
||
}
|
||
#ifdef TCL_MEM_DEBUG
|
||
if (quitFlag) {
|
||
Tcl_DeleteInterp(interp);
|
||
Tcl_DumpActiveMemory(dumpFile);
|
||
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);
|
||
return 1;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* 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. */
|
||
{
|
||
if (argc != 2) {
|
||
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
|
||
" fileName\"", (char *) NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
strcpy(dumpFile, argv[1]);
|
||
quitFlag = 1;
|
||
return TCL_OK;
|
||
}
|
||
#endif
|