diff options
Diffstat (limited to 'vendor/x11iraf/obm/Tcl/tclMain.c')
| -rw-r--r-- | vendor/x11iraf/obm/Tcl/tclMain.c | 296 |
1 files changed, 296 insertions, 0 deletions
diff --git a/vendor/x11iraf/obm/Tcl/tclMain.c b/vendor/x11iraf/obm/Tcl/tclMain.c new file mode 100644 index 00000000..f080dcd2 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tclMain.c @@ -0,0 +1,296 @@ +/* + * 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 |