home *** CD-ROM | disk | FTP | other *** search
/ Stone Design / Stone Design.iso / Stone_Friends / Wave / WavesWorld / Source / Libraries / tcl7.4b3 / tclMain.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-02-17  |  7.2 KB  |  288 lines
  1. /* 
  2.  * main.c --
  3.  *
  4.  *    Main program for Tcl shells and other Tcl-based applications.
  5.  *
  6.  * Copyright (c) 1988-1994 The Regents of the University of California.
  7.  * Copyright (c) 1994 Sun Microsystems, Inc.
  8.  *
  9.  * See the file "license.terms" for information on usage and redistribution
  10.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  11.  */
  12.  
  13. #ifndef lint
  14. static char sccsid[] = "@(#) tclMain.c 1.20 95/02/17 17:22:05";
  15. #endif
  16.  
  17. #include <stdio.h>
  18. #include <tcl.h>
  19. #include <errno.h>
  20. #ifdef NO_STDLIB_H
  21. #   include "compat/stdlib.h"
  22. #else
  23. #   include <stdlib.h>
  24. #endif
  25.  
  26. /*
  27.  * Declarations for various library procedures and variables (don't want
  28.  * to include tclPort.h here, because people might copy this file out of
  29.  * the Tcl source directory to make their own modified versions).
  30.  * Note:  "exit" should really be declared here, but there's no way to
  31.  * declare it without causing conflicts with other definitions elsewher
  32.  * on some systems, so it's better just to leave it out.
  33.  */
  34.  
  35. extern int        errno;
  36. extern int        isatty _ANSI_ARGS_((int fd));
  37. extern char *        strcpy _ANSI_ARGS_((char *dst, CONST char *src));
  38.  
  39. static Tcl_Interp *interp;    /* Interpreter for application. */
  40. static Tcl_DString command;    /* Used to buffer incomplete commands being
  41.                  * read from stdin. */
  42. #ifdef TCL_MEM_DEBUG
  43. static char dumpFile[100];    /* Records where to dump memory allocation
  44.                  * information. */
  45. static int quitFlag = 0;    /* 1 means the "checkmem" command was
  46.                  * invoked, so the application should quit
  47.                  * and dump memory allocation information. */
  48. #endif
  49.  
  50. /*
  51.  * Forward references for procedures defined later in this file:
  52.  */
  53.  
  54. #ifdef TCL_MEM_DEBUG
  55. static int        CheckmemCmd _ANSI_ARGS_((ClientData clientData,
  56.                 Tcl_Interp *interp, int argc, char *argv[]));
  57. #endif
  58.  
  59. /*
  60.  *----------------------------------------------------------------------
  61.  *
  62.  * Tcl_Main --
  63.  *
  64.  *    Main program for tclsh and most other Tcl-based applications.
  65.  *
  66.  * Results:
  67.  *    None. This procedure never returns (it exits the process when
  68.  *    it's done.
  69.  *
  70.  * Side effects:
  71.  *    This procedure initializes the Tk world and then starts
  72.  *    interpreting commands;  almost anything could happen, depending
  73.  *    on the script being interpreted.
  74.  *
  75.  *----------------------------------------------------------------------
  76.  */
  77.  
  78. void
  79. Tcl_Main(argc, argv)
  80.     int argc;                /* Number of arguments. */
  81.     char **argv;            /* Array of argument strings. */
  82. {
  83.     char buffer[1000], *cmd, *args, *fileName;
  84.     int code, gotPartial, tty;
  85.     int exitCode = 0;
  86.  
  87.     interp = Tcl_CreateInterp();
  88. #ifdef TCL_MEM_DEBUG
  89.     Tcl_InitMemory(interp);
  90.     Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, (ClientData) 0,
  91.         (Tcl_CmdDeleteProc *) NULL);
  92. #endif
  93.  
  94.     /*
  95.      * Make command-line arguments available in the Tcl variables "argc"
  96.      * and "argv".  If the first argument doesn't start with a "-" then
  97.      * strip it off and use it as the name of a script file to process.
  98.      */
  99.  
  100.     fileName = NULL;
  101.     if ((argc > 1) && (argv[1][0] != '-')) {
  102.     fileName = argv[1];
  103.     argc--;
  104.     argv++;
  105.     }
  106.     args = Tcl_Merge(argc-1, argv+1);
  107.     Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY);
  108.     ckfree(args);
  109.     sprintf(buffer, "%d", argc-1);
  110.     Tcl_SetVar(interp, "argc", buffer, TCL_GLOBAL_ONLY);
  111.     Tcl_SetVar(interp, "argv0", (fileName != NULL) ? fileName : argv[0],
  112.         TCL_GLOBAL_ONLY);
  113.  
  114.     /*
  115.      * Set the "tcl_interactive" variable.
  116.      */
  117.  
  118.     tty = isatty(0);
  119.     Tcl_SetVar(interp, "tcl_interactive",
  120.         ((fileName == NULL) && tty) ? "1" : "0", TCL_GLOBAL_ONLY);
  121.  
  122.     /*
  123.      * Invoke application-specific initialization.
  124.      */
  125.  
  126.     if (Tcl_AppInit(interp) != TCL_OK) {
  127.     fprintf(stderr, "Tcl_AppInit failed: %s\n", interp->result);
  128.     }
  129.  
  130.     /*
  131.      * If a script file was specified then just source that file
  132.      * and quit.
  133.      */
  134.  
  135.     if (fileName != NULL) {
  136.     code = Tcl_EvalFile(interp, fileName);
  137.     if (code != TCL_OK) {
  138.         fprintf(stderr, "%s\n", interp->result);
  139.         exitCode = 1;
  140.     }
  141.     goto done;
  142.     }
  143.  
  144.     /*
  145.      * We're running interactively.  Source a user-specific startup
  146.      * file if Tcl_AppInit specified one and if the file exists.
  147.      */
  148.  
  149.     if (tcl_RcFileName != NULL) {
  150.     Tcl_DString buffer;
  151.     char *fullName;
  152.     FILE *f;
  153.  
  154.     fullName = Tcl_TildeSubst(interp, tcl_RcFileName, &buffer);
  155.     if (fullName == NULL) {
  156.         fprintf(stderr, "%s\n", interp->result);
  157.     } else {
  158.         f = fopen(fullName, "r");
  159.         if (f != NULL) {
  160.         code = Tcl_EvalFile(interp, fullName);
  161.         if (code != TCL_OK) {
  162.             fprintf(stderr, "%s\n", interp->result);
  163.         }
  164.         fclose(f);
  165.         }
  166.     }
  167.     Tcl_DStringFree(&buffer);
  168.     }
  169.  
  170.     /*
  171.      * Process commands from stdin until there's an end-of-file.
  172.      */
  173.  
  174.     gotPartial = 0;
  175.     Tcl_DStringInit(&command);
  176.     while (1) {
  177.     clearerr(stdin);
  178.     if (tty) {
  179.         char *promptCmd;
  180.  
  181.         promptCmd = Tcl_GetVar(interp,
  182.         gotPartial ? "tcl_prompt2" : "tcl_prompt1", TCL_GLOBAL_ONLY);
  183.         if (promptCmd == NULL) {
  184.         defaultPrompt:
  185.         if (!gotPartial) {
  186.             fputs("% ", stdout);
  187.         }
  188.         } else {
  189.         code = Tcl_Eval(interp, promptCmd);
  190.         if (code != TCL_OK) {
  191.             fprintf(stderr, "%s\n", interp->result);
  192.             Tcl_AddErrorInfo(interp,
  193.                 "\n    (script that generates prompt)");
  194.             goto defaultPrompt;
  195.         }
  196.         }
  197.         fflush(stdout);
  198.     }
  199.     if (fgets(buffer, 1000, stdin) == NULL) {
  200.         if (ferror(stdin)) {
  201.         if (errno == EINTR) {
  202.             if (tcl_AsyncReady) {
  203.             (void) Tcl_AsyncInvoke((Tcl_Interp *) NULL, 0);
  204.             }
  205.             clearerr(stdin);
  206.         } else {
  207.             goto done;
  208.         }
  209.         } else {
  210.         if (!gotPartial) {
  211.             goto done;
  212.         }
  213.         }
  214.         buffer[0] = 0;
  215.     }
  216.     cmd = Tcl_DStringAppend(&command, buffer, -1);
  217.     if ((buffer[0] != 0) && !Tcl_CommandComplete(cmd)) {
  218.         gotPartial = 1;
  219.         continue;
  220.     }
  221.  
  222.     gotPartial = 0;
  223.     code = Tcl_RecordAndEval(interp, cmd, 0);
  224.     Tcl_DStringFree(&command);
  225.     if (code != TCL_OK) {
  226.         fprintf(stderr, "%s\n", interp->result);
  227.     } else if (tty && (*interp->result != 0)) {
  228.         printf("%s\n", interp->result);
  229.     }
  230. #ifdef TCL_MEM_DEBUG
  231.     if (quitFlag) {
  232.         Tcl_DeleteInterp(interp);
  233.         Tcl_DumpActiveMemory(dumpFile);
  234.         exit(0);
  235.     }
  236. #endif
  237.     }
  238.  
  239.     /*
  240.      * Rather than calling exit, invoke the "exit" command so that
  241.      * users can replace "exit" with some other command to do additional
  242.      * cleanup on exit.  The Tcl_Eval call should never return.
  243.      */
  244.  
  245.     done:
  246.     sprintf(buffer, "exit %d", exitCode);
  247.     Tcl_Eval(interp, buffer);
  248. }
  249.  
  250. /*
  251.  *----------------------------------------------------------------------
  252.  *
  253.  * CheckmemCmd --
  254.  *
  255.  *    This is the command procedure for the "checkmem" command, which
  256.  *    causes the application to exit after printing information about
  257.  *    memory usage to the file passed to this command as its first
  258.  *    argument.
  259.  *
  260.  * Results:
  261.  *    Returns a standard Tcl completion code.
  262.  *
  263.  * Side effects:
  264.  *    None.
  265.  *
  266.  *----------------------------------------------------------------------
  267.  */
  268. #ifdef TCL_MEM_DEBUG
  269.  
  270.     /* ARGSUSED */
  271. static int
  272. CheckmemCmd(clientData, interp, argc, argv)
  273.     ClientData clientData;        /* Not used. */
  274.     Tcl_Interp *interp;            /* Interpreter for evaluation. */
  275.     int argc;                /* Number of arguments. */
  276.     char *argv[];            /* String values of arguments. */
  277. {
  278.     if (argc != 2) {
  279.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  280.         " fileName\"", (char *) NULL);
  281.     return TCL_ERROR;
  282.     }
  283.     strcpy(dumpFile, argv[1]);
  284.     quitFlag = 1;
  285.     return TCL_OK;
  286. }
  287. #endif
  288.