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