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