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