home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / tcl / tcl7.0b1 / tclMain.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-06-17  |  5.6 KB  |  208 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.2 93/06/17 16:13:53 ouster Exp $ SPRITE (Berkeley)";
  29. #endif
  30.  
  31. #include "tclInt.h"
  32. #include "tclUnix.h"
  33.  
  34. static Tcl_Interp *interp;    /* Interpreter for application. */
  35. static Tcl_DString command;    /* Used to buffer incomplete commands being
  36.                  * read from stdin. */
  37. #ifdef TCL_MEM_DEBUG
  38. static char dumpFile[100];    /* Records where to dump memory allocation
  39.                  * information. */
  40. static int quitFlag = 0;    /* 1 means the "checkmem" command was
  41.                  * invoked, so the application should quit
  42.                  * and dump memory allocation information. */
  43. #endif
  44.  
  45. /*
  46.  * Forward references for procedures defined later in this file:
  47.  */
  48.  
  49. static int        CheckmemCmd _ANSI_ARGS_((ClientData clientData,
  50.                 Tcl_Interp *interp, int argc, char *argv[]));
  51.  
  52. /*
  53.  *----------------------------------------------------------------------
  54.  *
  55.  * main --
  56.  *
  57.  *    This is the main program for a Tcl-based shell that reads
  58.  *    Tcl commands from standard input.
  59.  *
  60.  * Results:
  61.  *    None.
  62.  *
  63.  * Side effects:
  64.  *    Can be almost arbitrary, depending on what the Tcl commands do.
  65.  *
  66.  *----------------------------------------------------------------------
  67.  */
  68.  
  69. int
  70. main(argc, argv)
  71.     int argc;                /* Number of arguments. */
  72.     char **argv;            /* Array of argument strings. */
  73. {
  74.     char buffer[1000], *cmd, *args, *fileName;
  75.     int result, gotPartial, tty;
  76.  
  77.     interp = Tcl_CreateInterp();
  78. #ifdef TCL_MEM_DEBUG
  79.     Tcl_InitMemory(interp);
  80.     Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, (ClientData) 0,
  81.         (Tcl_CmdDeleteProc *) NULL);
  82. #endif
  83.  
  84.     /*
  85.      * Make command-line arguments available in the Tcl variables "argc"
  86.      * and "argv".  If the first argument doesn't start with a "-" then
  87.      * strip it off and use it as the name of a script file to process.
  88.      */
  89.  
  90.     fileName = NULL;
  91.     if ((argc > 1) && (argv[1][0] != '-')) {
  92.     fileName = argv[1];
  93.     argc--;
  94.     argv++;
  95.     }
  96.     args = Tcl_Merge(argc-1, argv+1);
  97.     Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY);
  98.     ckfree(args);
  99.     sprintf(buffer, "%d", argc-1);
  100.     Tcl_SetVar(interp, "argc", buffer, TCL_GLOBAL_ONLY);
  101.     Tcl_SetVar(interp, "argv0", (fileName != NULL) ? fileName : argv[0],
  102.         TCL_GLOBAL_ONLY);
  103.  
  104.     /*
  105.      * Invoke application-specific initialization.
  106.      */
  107.  
  108.     if (Tcl_AppInit(interp) != TCL_OK) {
  109.     fprintf(stderr, "%s\n", interp->result);
  110.     exit(1);
  111.     }
  112.  
  113.     /*
  114.      * If a script file was specified then just source that file
  115.      * and quit.
  116.      */
  117.  
  118.     if (fileName != NULL) {
  119.     result = Tcl_EvalFile(interp, fileName);
  120.     if (result != TCL_OK) {
  121.         fprintf(stderr, "%s\n", interp->result);
  122.         exit(1);
  123.     }
  124.     exit(0);
  125.     }
  126.  
  127.     /*
  128.      * Process commands from stdin until there's an end-of-file.
  129.      */
  130.  
  131.     gotPartial = 0;
  132.     tty = isatty(0);
  133.     Tcl_DStringInit(&command);
  134.     while (1) {
  135.     clearerr(stdin);
  136.     if (!gotPartial && tty) {
  137.         fputs("% ", stdout);
  138.         fflush(stdout);
  139.     }
  140.     if (fgets(buffer, 1000, stdin) == NULL) {
  141.         if (!gotPartial) {
  142.         exit(0);
  143.         }
  144.         buffer[0] = 0;
  145.     }
  146.     cmd = Tcl_DStringAppend(&command, buffer, -1);
  147.     if ((buffer[0] != 0) && !Tcl_CommandComplete(cmd)) {
  148.         gotPartial = 1;
  149.         continue;
  150.     }
  151.  
  152.     gotPartial = 0;
  153.     result = Tcl_RecordAndEval(interp, cmd, 0);
  154.     Tcl_DStringFree(&command);
  155.     if (result != TCL_OK) {
  156.         fprintf(stderr, "%s\n", interp->result);
  157.     } else if (tty && (*interp->result != 0)) {
  158.         printf("%s\n", interp->result);
  159.     }
  160. #ifdef TCL_MEM_DEBUG
  161.     if (quitFlag) {
  162.         Tcl_DeleteInterp(interp);
  163.         Tcl_DumpActiveMemory(dumpFile);
  164.         exit(0);
  165.     }
  166. #endif
  167.     }
  168. }
  169.  
  170. /*
  171.  *----------------------------------------------------------------------
  172.  *
  173.  * CheckmemCmd --
  174.  *
  175.  *    This is the command procedure for the "checkmem" command, which
  176.  *    causes the application to exit after printing information about
  177.  *    memory usage to the file passed to this command as its first
  178.  *    argument.
  179.  *
  180.  * Results:
  181.  *    Returns a standard Tcl completion code.
  182.  *
  183.  * Side effects:
  184.  *    None.
  185.  *
  186.  *----------------------------------------------------------------------
  187.  */
  188. #ifdef TCL_MEM_DEBUG
  189.  
  190.     /* ARGSUSED */
  191. static int
  192. CheckmemCmd(clientData, interp, argc, argv)
  193.     ClientData clientData;        /* Not used. */
  194.     Tcl_Interp *interp;            /* Interpreter for evaluation. */
  195.     int argc;                /* Number of arguments. */
  196.     char *argv[];            /* String values of arguments. */
  197. {
  198.     if (argc != 2) {
  199.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  200.         " fileName\"", (char *) NULL);
  201.     return TCL_ERROR;
  202.     }
  203.     strcpy(dumpFile, argv[1]);
  204.     quitFlag = 1;
  205.     return TCL_OK;
  206. }
  207. #endif
  208.