home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / tcl2-73c.zip / tcl7.3 / tclmain.c < prev    next >
C/C++ Source or Header  |  1994-03-12  |  8KB  |  300 lines
  1. /* 
  2.  * main.c --
  3.  *
  4.  *    Main program for Tcl shells and other Tcl-based applications.
  5.  *
  6.  * Copyright (c) 1988-1993 The Regents of the University of California.
  7.  * All rights reserved.
  8.  *
  9.  * Permission is hereby granted, without written agreement and without
  10.  * license or royalty fees, to use, copy, modify, and distribute this
  11.  * software and its documentation for any purpose, provided that the
  12.  * above copyright notice and the following two paragraphs appear in
  13.  * all copies of this software.
  14.  * 
  15.  * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
  16.  * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
  17.  * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
  18.  * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  19.  *
  20.  * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
  21.  * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  22.  * AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
  23.  * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
  24.  * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
  25.  */
  26.  
  27. #ifndef lint
  28. static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclMain.c,v 1.12 93/11/11 09:35:10 ouster Exp $ SPRITE (Berkeley)";
  29. #endif
  30.  
  31. #include <stdio.h>
  32. #include <tcl.h>
  33. #include <errno.h>
  34. #ifdef __OS2__
  35. #include <io.h>
  36. #endif
  37.  
  38. /*
  39.  * Declarations for various library procedures and variables (don't want
  40.  * to include tclUnix.h here, because people might copy this file out of
  41.  * the Tcl source directory to make their own modified versions).
  42.  */
  43.  
  44. extern int        errno;
  45. extern void        exit _ANSI_ARGS_((int status));
  46. extern int        isatty _ANSI_ARGS_((int fd));
  47. extern char *        strcpy _ANSI_ARGS_((char *dst, CONST char *src));
  48.  
  49. static Tcl_Interp *interp;    /* Interpreter for application. */
  50. static Tcl_DString command;    /* Used to buffer incomplete commands being
  51.                  * read from stdin. */
  52. char *tcl_RcFileName = NULL;    /* Name of a user-specific startup script
  53.                  * to source if the application is being run
  54.                  * interactively (e.g. "~/.tclshrc").  Set
  55.                  * by Tcl_AppInit.  NULL means don't source
  56.                  * anything ever. */
  57. #ifdef TCL_MEM_DEBUG
  58. static char dumpFile[100];    /* Records where to dump memory allocation
  59.                  * information. */
  60. static int quitFlag = 0;    /* 1 means the "checkmem" command was
  61.                  * invoked, so the application should quit
  62.                  * and dump memory allocation information. */
  63. #endif
  64.  
  65. /*
  66.  * Forward references for procedures defined later in this file:
  67.  */
  68.  
  69. static int        CheckmemCmd _ANSI_ARGS_((ClientData clientData,
  70.                 Tcl_Interp *interp, int argc, char *argv[]));
  71.  
  72. /*
  73.  *----------------------------------------------------------------------
  74.  *
  75.  * main --
  76.  *
  77.  *    This is the main program for a Tcl-based shell that reads
  78.  *    Tcl commands from standard input.
  79.  *
  80.  * Results:
  81.  *    None.
  82.  *
  83.  * Side effects:
  84.  *    Can be almost arbitrary, depending on what the Tcl commands do.
  85.  *
  86.  *----------------------------------------------------------------------
  87.  */
  88.  
  89. int
  90. main(argc, argv)
  91.     int argc;                /* Number of arguments. */
  92.     char **argv;            /* Array of argument strings. */
  93. {
  94.     char buffer[1000], *cmd, *args, *fileName;
  95.     int code, gotPartial, tty;
  96.     int exitCode = 0;
  97.  
  98.     interp = Tcl_CreateInterp();
  99. #ifdef TCL_MEM_DEBUG
  100.     Tcl_InitMemory(interp);
  101.     Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, (ClientData) 0,
  102.         (Tcl_CmdDeleteProc *) NULL);
  103. #endif
  104.  
  105.     /*
  106.      * Make command-line arguments available in the Tcl variables "argc"
  107.      * and "argv".  If the first argument doesn't start with a "-" then
  108.      * strip it off and use it as the name of a script file to process.
  109.      */
  110.  
  111.     fileName = NULL;
  112.     if ((argc > 1) && (argv[1][0] != '-')) {
  113.     fileName = argv[1];
  114.     argc--;
  115.     argv++;
  116.     }
  117.     args = Tcl_Merge(argc-1, argv+1);
  118.     Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY);
  119.     ckfree(args);
  120.     sprintf(buffer, "%d", argc-1);
  121.     Tcl_SetVar(interp, "argc", buffer, TCL_GLOBAL_ONLY);
  122.     Tcl_SetVar(interp, "argv0", (fileName != NULL) ? fileName : argv[0],
  123.         TCL_GLOBAL_ONLY);
  124.  
  125.     /*
  126.      * Set the "tcl_interactive" variable.
  127.      */
  128.  
  129.     tty = isatty(0);
  130.     Tcl_SetVar(interp, "tcl_interactive",
  131.         ((fileName == NULL) && tty) ? "1" : "0", TCL_GLOBAL_ONLY);
  132.  
  133.     /*
  134.      * Invoke application-specific initialization.
  135.      */
  136.  
  137.     if (Tcl_AppInit(interp) != TCL_OK) {
  138.     fprintf(stderr, "Tcl_AppInit failed: %s\n", interp->result);
  139.     }
  140.  
  141.     /*
  142.      * If a script file was specified then just source that file
  143.      * and quit.
  144.      */
  145.  
  146.     if (fileName != NULL) {
  147.     code = Tcl_EvalFile(interp, fileName);
  148.     if (code != TCL_OK) {
  149.         fprintf(stderr, "%s\n", interp->result);
  150.         exitCode = 1;
  151.     }
  152.     goto done;
  153.     }
  154.  
  155.     /*
  156.      * We're running interactively.  Source a user-specific startup
  157.      * file if Tcl_AppInit specified one and if the file exists.
  158.      */
  159.  
  160.     if (tcl_RcFileName != NULL) {
  161.     Tcl_DString buffer;
  162.     char *fullName;
  163.     FILE *f;
  164.  
  165.     fullName = Tcl_TildeSubst(interp, tcl_RcFileName, &buffer);
  166.     if (fullName == NULL) {
  167.         fprintf(stderr, "%s\n", interp->result);
  168.     } else {
  169.         f = fopen(fullName, "r");
  170.         if (f != NULL) {
  171.         code = Tcl_EvalFile(interp, fullName);
  172.         if (code != TCL_OK) {
  173.             fprintf(stderr, "%s\n", interp->result);
  174.         }
  175.         fclose(f);
  176.         }
  177.     }
  178.     Tcl_DStringFree(&buffer);
  179.     }
  180.  
  181.     /*
  182.      * Process commands from stdin until there's an end-of-file.
  183.      */
  184.  
  185.     gotPartial = 0;
  186.     Tcl_DStringInit(&command);
  187.     while (1) {
  188.     clearerr(stdin);
  189.     if (tty) {
  190.         char *promptCmd;
  191.  
  192.         promptCmd = Tcl_GetVar(interp,
  193.         gotPartial ? "tcl_prompt2" : "tcl_prompt1", TCL_GLOBAL_ONLY);
  194.         if (promptCmd == NULL) {
  195.         defaultPrompt:
  196.         if (!gotPartial) {
  197.             fputs("% ", stdout);
  198.         }
  199.         } else {
  200.         code = Tcl_Eval(interp, promptCmd);
  201.         if (code != TCL_OK) {
  202.             fprintf(stderr, "%s\n", interp->result);
  203.             Tcl_AddErrorInfo(interp,
  204.                 "\n    (script that generates prompt)");
  205.             goto defaultPrompt;
  206.         }
  207.         }
  208.         fflush(stdout);
  209.     }
  210.     if (fgets(buffer, 1000, stdin) == NULL) {
  211.         if (ferror(stdin)) {
  212.         if (errno == EINTR) {
  213.             if (tcl_AsyncReady) {
  214.             (void) Tcl_AsyncInvoke((Tcl_Interp *) NULL, 0);
  215.             }
  216.             clearerr(stdin);
  217.         } else {
  218.             goto done;
  219.         }
  220.         } else {
  221.         if (!gotPartial) {
  222.             goto done;
  223.         }
  224.         }
  225.         buffer[0] = 0;
  226.     }
  227.     cmd = Tcl_DStringAppend(&command, buffer, -1);
  228.     if ((buffer[0] != 0) && !Tcl_CommandComplete(cmd)) {
  229.         gotPartial = 1;
  230.         continue;
  231.     }
  232.  
  233.     gotPartial = 0;
  234.     code = Tcl_RecordAndEval(interp, cmd, 0);
  235.     Tcl_DStringFree(&command);
  236.     if (code != TCL_OK) {
  237.         fprintf(stderr, "%s\n", interp->result);
  238.     } else if (tty && (*interp->result != 0)) {
  239.         printf("%s\n", interp->result);
  240.     }
  241. #ifdef TCL_MEM_DEBUG
  242.     if (quitFlag) {
  243.         Tcl_DeleteInterp(interp);
  244.         Tcl_DumpActiveMemory(dumpFile);
  245.         exit(0);
  246.     }
  247. #endif
  248.     }
  249.  
  250.     /*
  251.      * Rather than calling exit, invoke the "exit" command so that
  252.      * users can replace "exit" with some other command to do additional
  253.      * cleanup on exit.  The Tcl_Eval call should never return.
  254.      */
  255.  
  256.     done:
  257.     sprintf(buffer, "exit %d", exitCode);
  258.     Tcl_Eval(interp, buffer);
  259.     return 1;
  260. }
  261.  
  262. /*
  263.  *----------------------------------------------------------------------
  264.  *
  265.  * CheckmemCmd --
  266.  *
  267.  *    This is the command procedure for the "checkmem" command, which
  268.  *    causes the application to exit after printing information about
  269.  *    memory usage to the file passed to this command as its first
  270.  *    argument.
  271.  *
  272.  * Results:
  273.  *    Returns a standard Tcl completion code.
  274.  *
  275.  * Side effects:
  276.  *    None.
  277.  *
  278.  *----------------------------------------------------------------------
  279.  */
  280. #ifdef TCL_MEM_DEBUG
  281.  
  282.     /* ARGSUSED */
  283. static int
  284. CheckmemCmd(clientData, interp, argc, argv)
  285.     ClientData clientData;        /* Not used. */
  286.     Tcl_Interp *interp;            /* Interpreter for evaluation. */
  287.     int argc;                /* Number of arguments. */
  288.     char *argv[];            /* String values of arguments. */
  289. {
  290.     if (argc != 2) {
  291.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  292.         " fileName\"", (char *) NULL);
  293.     return TCL_ERROR;
  294.     }
  295.     strcpy(dumpFile, argv[1]);
  296.     quitFlag = 1;
  297.     return TCL_OK;
  298. }
  299. #endif
  300.