home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / tkisrc04.zip / tcl / os2 / tclMain.c < prev    next >
C/C++ Source or Header  |  1998-08-07  |  10KB  |  348 lines
  1. /* 
  2.  * tclMain.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-1996 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.  * SCCS: @(#) tclMain.c 1.50 96/04/10 16:40:57
  13.  */
  14.  
  15. #include "tcl.h"
  16. #include "tclInt.h"
  17.  
  18. /*
  19.  * The following code ensures that tclLink.c is linked whenever
  20.  * Tcl is linked.  Without this code there's no reference to the
  21.  * code in that file from anywhere in Tcl, so it may not be
  22.  * linked into the application.
  23.  */
  24.  
  25. EXTERN int Tcl_LinkVar();
  26. int (*tclDummyLinkVarPtr)() = Tcl_LinkVar;
  27.  
  28. /*
  29.  * Declarations for various library procedures and variables (don't want
  30.  * to include tclPort.h here, because people might copy this file out of
  31.  * the Tcl source directory to make their own modified versions).
  32.  * Note:  "exit" should really be declared here, but there's no way to
  33.  * declare it without causing conflicts with other definitions elsewher
  34.  * on some systems, so it's better just to leave it out.
  35.  */
  36.  
  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, length;
  90.     int exitCode = 0;
  91.     Tcl_Channel inChannel, outChannel, errChannel;
  92.     Tcl_DString temp;
  93.  
  94.     Tcl_FindExecutable(argv[0]);
  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 ((*appInitProc)(interp) != TCL_OK) {
  135.     errChannel = Tcl_GetStdChannel(TCL_STDERR);
  136.     if (errChannel) {
  137.         Tcl_Write(errChannel,
  138.             "application-specific initialization failed: ", -1);
  139.         Tcl_Write(errChannel, interp->result, -1);
  140.         Tcl_Write(errChannel, "\n", 1);
  141.     }
  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.         errChannel = Tcl_GetStdChannel(TCL_STDERR);
  153.         if (errChannel) {
  154.         /*
  155.          * The following statement guarantees that the errorInfo
  156.          * variable is set properly.
  157.          */
  158.  
  159.         Tcl_AddErrorInfo(interp, "");
  160.         Tcl_Write(errChannel,
  161.             Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY), -1);
  162.         Tcl_Write(errChannel, "\n", 1);
  163.         }
  164.         exitCode = 1;
  165.     }
  166.     goto done;
  167.     }
  168.  
  169.     /*
  170.      * We're running interactively.  Source a user-specific startup
  171.      * file if the application specified one and if the file exists.
  172.      */
  173.  
  174.     fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY);
  175.  
  176.     if (fileName != NULL) {
  177.         Tcl_Channel c;
  178.     char *fullName;
  179.  
  180.         Tcl_DStringInit(&temp);
  181.     fullName = Tcl_TranslateFileName(interp, fileName, &temp);
  182.     if (fullName == NULL) {
  183.         errChannel = Tcl_GetStdChannel(TCL_STDERR);
  184.         if (errChannel) {
  185.         Tcl_Write(errChannel, interp->result, -1);
  186.         Tcl_Write(errChannel, "\n", 1);
  187.         }
  188.     } else {
  189.  
  190.         /*
  191.          * Test for the existence of the rc file before trying to read it.
  192.          */
  193.  
  194.             c = Tcl_OpenFileChannel(NULL, fullName, "r", 0);
  195.             if (c != (Tcl_Channel) NULL) {
  196.                 Tcl_Close(NULL, c);
  197.         if (Tcl_EvalFile(interp, fullName) != TCL_OK) {
  198.             errChannel = Tcl_GetStdChannel(TCL_STDERR);
  199.             if (errChannel) {
  200.             Tcl_Write(errChannel, interp->result, -1);
  201.             Tcl_Write(errChannel, "\n", 1);
  202.             }
  203.         }
  204.         }
  205.     }
  206.         Tcl_DStringFree(&temp);
  207.     }
  208.  
  209.     /*
  210.      * Process commands from stdin until there's an end-of-file.  Note
  211.      * that we need to fetch the standard channels again after every
  212.      * eval, since they may have been changed.
  213.      */
  214.  
  215.     gotPartial = 0;
  216.     Tcl_DStringInit(&command);
  217.     inChannel = Tcl_GetStdChannel(TCL_STDIN);
  218.     outChannel = Tcl_GetStdChannel(TCL_STDOUT);
  219.     while (1) {
  220.     if (tty) {
  221.         char *promptCmd;
  222.  
  223.         promptCmd = Tcl_GetVar(interp,
  224.         gotPartial ? "tcl_prompt2" : "tcl_prompt1", TCL_GLOBAL_ONLY);
  225.         if (promptCmd == NULL) {
  226. defaultPrompt:
  227.         if (!gotPartial && outChannel) {
  228.             Tcl_Write(outChannel, "% ", 2);
  229.         }
  230.         } else {
  231.         code = Tcl_Eval(interp, promptCmd);
  232.         inChannel = Tcl_GetStdChannel(TCL_STDIN);
  233.         outChannel = Tcl_GetStdChannel(TCL_STDOUT);
  234.         errChannel = Tcl_GetStdChannel(TCL_STDERR);
  235.         if (code != TCL_OK) {
  236.             if (errChannel) {
  237.             Tcl_Write(errChannel, interp->result, -1);
  238.             Tcl_Write(errChannel, "\n", 1);
  239.             }
  240.             Tcl_AddErrorInfo(interp,
  241.                 "\n    (script that generates prompt)");
  242.             goto defaultPrompt;
  243.         }
  244.         }
  245.         if (outChannel) {
  246.         Tcl_Flush(outChannel);
  247.         }
  248.     }
  249.     if (!inChannel) {
  250.         goto done;
  251.     }
  252.         length = Tcl_Gets(inChannel, &command);
  253.     if (length < 0) {
  254.         goto done;
  255.     }
  256.     if ((length == 0) && Tcl_Eof(inChannel) && (!gotPartial)) {
  257.         goto done;
  258.     }
  259.  
  260.         /*
  261.          * Add the newline removed by Tcl_Gets back to the string.
  262.          */
  263.         
  264.         (void) Tcl_DStringAppend(&command, "\n", -1);
  265.  
  266.     cmd = Tcl_DStringValue(&command);
  267.     if (!Tcl_CommandComplete(cmd)) {
  268.         gotPartial = 1;
  269.         continue;
  270.     }
  271.  
  272.     gotPartial = 0;
  273.     code = Tcl_RecordAndEval(interp, cmd, 0);
  274.     inChannel = Tcl_GetStdChannel(TCL_STDIN);
  275.     outChannel = Tcl_GetStdChannel(TCL_STDOUT);
  276.     errChannel = Tcl_GetStdChannel(TCL_STDERR);
  277.     Tcl_DStringFree(&command);
  278.     if (code != TCL_OK) {
  279.         if (errChannel) {
  280.         Tcl_Write(errChannel, interp->result, -1);
  281.         Tcl_Write(errChannel, "\n", 1);
  282.         }
  283.     } else if (tty && (*interp->result != 0)) {
  284.         if (outChannel) {
  285.         Tcl_Write(outChannel, interp->result, -1);
  286.         Tcl_Write(outChannel, "\n", 1);
  287.         }
  288.     }
  289. #ifdef TCL_MEM_DEBUG
  290.     if (quitFlag) {
  291.         Tcl_DeleteInterp(interp);
  292.         Tcl_Exit(0);
  293.     }
  294. #endif
  295.     }
  296.  
  297.     /*
  298.      * Rather than calling exit, invoke the "exit" command so that
  299.      * users can replace "exit" with some other command to do additional
  300.      * cleanup on exit.  The Tcl_Eval call should never return.
  301.      */
  302.  
  303. done:
  304.     sprintf(buffer, "exit %d", exitCode);
  305.     Tcl_Eval(interp, buffer);
  306. }
  307.  
  308. /*
  309.  *----------------------------------------------------------------------
  310.  *
  311.  * CheckmemCmd --
  312.  *
  313.  *    This is the command procedure for the "checkmem" command, which
  314.  *    causes the application to exit after printing information about
  315.  *    memory usage to the file passed to this command as its first
  316.  *    argument.
  317.  *
  318.  * Results:
  319.  *    Returns a standard Tcl completion code.
  320.  *
  321.  * Side effects:
  322.  *    None.
  323.  *
  324.  *----------------------------------------------------------------------
  325.  */
  326. #ifdef TCL_MEM_DEBUG
  327.  
  328.     /* ARGSUSED */
  329. static int
  330. CheckmemCmd(clientData, interp, argc, argv)
  331.     ClientData clientData;        /* Not used. */
  332.     Tcl_Interp *interp;            /* Interpreter for evaluation. */
  333.     int argc;                /* Number of arguments. */
  334.     char *argv[];            /* String values of arguments. */
  335. {
  336.     extern char *tclMemDumpFileName;
  337.     if (argc != 2) {
  338.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  339.         " fileName\"", (char *) NULL);
  340.     return TCL_ERROR;
  341.     }
  342.     strcpy(dumpFile, argv[1]);
  343.     tclMemDumpFileName = dumpFile;
  344.     quitFlag = 1;
  345.     return TCL_OK;
  346. }
  347. #endif
  348.