home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / tkisrc04.zip / tcl / os2 / tclOS2Main.c < prev    next >
C/C++ Source or Header  |  1998-08-07  |  12KB  |  415 lines
  1. /* 
  2.  * tclOS2Main.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 Sun Microsystems, Inc.
  8.  * Copyright (c) 1996-1997 Illya Vaes
  9.  *
  10.  * See the file "license.terms" for information on usage and redistribution
  11.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  12.  */
  13.  
  14. #include        "tclInt.h"      /* Internal definitions for Tcl. */
  15. #include        "tclPort.h"     /* Portability features for Tcl. */
  16. #include "tclOS2Console.h"
  17.  
  18. static Tcl_Interp *interp;    /* Interpreter for application. */
  19. static Tcl_DString command;    /* Used to buffer incomplete commands being
  20.                  * read from stdin. */
  21.  
  22. #ifdef TCL_MEM_DEBUG
  23. static char dumpFile[100];    /* Records where to dump memory allocation
  24.                  * information. */
  25. static int quitFlag = 0;    /* 1 means the "checkmem" command was
  26.                  * invoked, so the application should quit
  27.                  * and dump memory allocation information. */
  28. #endif
  29.  
  30. /*
  31.  * Forward references for procedures defined later in this file:
  32.  */
  33.  
  34. static void TclOS2Panic TCL_VARARGS(char *,format);
  35. #ifdef TCL_MEM_DEBUG
  36. static int        CheckmemCmd _ANSI_ARGS_((ClientData clientData,
  37.                 Tcl_Interp *interp, int argc, char *argv[]));
  38. #endif
  39.  
  40.  
  41. /*
  42.  *----------------------------------------------------------------------
  43.  *
  44.  * Tcl_Main --
  45.  *
  46.  *    Main program for tclsh and most other Tcl-based applications.
  47.  *
  48.  * Results:
  49.  *    None. This procedure never returns (it exits the process when
  50.  *    it's done.
  51.  *
  52.  * Side effects:
  53.  *    This procedure initializes the Tcl world and then starts
  54.  *    interpreting commands;  almost anything could happen, depending
  55.  *    on the script being interpreted.
  56.  *
  57.  *----------------------------------------------------------------------
  58.  */
  59.  
  60. void
  61. Tcl_Main(argc, argv, appInitProc)
  62.     int argc;                /* Number of arguments. */
  63.     char **argv;            /* Array of argument strings. */
  64.     Tcl_AppInitProc *appInitProc;    /* Application-specific initialization
  65.                      * procedure to call after most
  66.                      * initialization but before starting
  67.                      * to execute commands. */
  68. {
  69.     char cbuf[1000], *args, *fileName;
  70.     int code, gotPartial;
  71. #ifdef CLI_VERSION
  72.     char *cmd;
  73.     int length;
  74.     int tty = 1;
  75. #endif
  76.     int exitCode = 0;
  77.     Tcl_Channel inChannel, outChannel, errChannel;
  78.     HWND hTerminal;
  79.  
  80.     /* Initialize PM */
  81.     if (!PMInitialize()) {
  82.         return;
  83.     }
  84.     /* Set Panic procedure */
  85.     Tcl_SetPanicProc(TclOS2Panic);
  86. #ifndef CLI_VERSION
  87.     /* Register "Terminal" class */
  88.     if (!RegisterTerminalClass(TclOS2GetHAB())) {
  89.         WinMessageBox(HWND_DESKTOP, NULLHANDLE, "Cannot register Terminal",
  90.                       "Tclsh", 0, MB_OK | MB_ERROR | MB_APPLMODAL);
  91.         /* Don't forget to cleanly exit PM */
  92.         PMShutdown();
  93.         return;
  94.     }
  95. #endif
  96.  
  97.     Tcl_FindExecutable(argv[0]);
  98.  
  99.     interp = Tcl_CreateInterp();
  100. #ifdef TCL_MEM_DEBUG
  101.     Tcl_InitMemory(interp);
  102.     Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, (ClientData) 0,
  103.         (Tcl_CmdDeleteProc *) NULL);
  104. #endif
  105.  
  106.     /*
  107.      * Make command-line arguments available in the Tcl variables "argc"
  108.      * and "argv".  If the first argument doesn't start with a "-" then
  109.      * strip it off and use it as the name of a script file to process.
  110.      */
  111.  
  112.     fileName = NULL;
  113.     if ((argc > 1) && (argv[1][0] != '-')) {
  114.     fileName = argv[1];
  115.     argc--;
  116.     argv++;
  117.     }
  118.     args = Tcl_Merge(argc-1, argv+1);
  119.     Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY);
  120.     ckfree(args);
  121.     sprintf(cbuf, "%d", argc-1);
  122.     Tcl_SetVar(interp, "argc", cbuf, TCL_GLOBAL_ONLY);
  123.     Tcl_SetVar(interp, "argv0", (fileName != NULL) ? fileName : argv[0],
  124.         TCL_GLOBAL_ONLY);
  125.  
  126.     /*
  127.      * Set the "tcl_interactive" variable.
  128.      */
  129.  
  130.     Tcl_SetVar(interp, "tcl_interactive",
  131.         (fileName == NULL) ? "1" : "0", TCL_GLOBAL_ONLY);
  132.  
  133.     /*
  134.      * Invoke application-specific initialization.
  135.      */
  136.  
  137.     if ((*appInitProc)(interp) != TCL_OK) {
  138. #ifndef CLI_VERSION
  139.     sprintf(cbuf, "application-specific initialization failed: %s\n",
  140.         interp->result);
  141.         WinMessageBox(HWND_DESKTOP, NULLHANDLE, cbuf, "Tclsh",
  142.                       0, MB_OK | MB_ICONEXCLAMATION | MB_APPLMODAL);
  143. #else
  144.         fprintf(stderr, "application-specific initialization failed: %s\n",
  145.                 interp->result);
  146. #endif
  147.     }
  148.  
  149.     /*
  150.      * If a script file was specified then just source that file
  151.      * and quit.
  152.      */
  153.  
  154.     if (fileName != NULL) {
  155.     code = Tcl_EvalFile(interp, fileName);
  156.     if (code != TCL_OK) {
  157. #ifndef CLI_VERSION
  158.         sprintf(cbuf, "%s\n", interp->result);
  159.             WinMessageBox(HWND_DESKTOP, NULLHANDLE, cbuf, "Tclsh", 0,
  160.                           MB_OK | MB_ERROR | MB_APPLMODAL);
  161. #else
  162.             fprintf(stderr, "%s\n", interp->result);
  163. #endif
  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_DString buffer;
  178.     char *fullName;
  179.     FILE *f;
  180.  
  181.     fullName = Tcl_TildeSubst(interp, fileName, &buffer);
  182.     if (fullName == NULL) {
  183. #ifndef CLI_VERSION
  184.         sprintf(cbuf, "%s\n", interp->result);
  185.             WinMessageBox(HWND_DESKTOP, NULLHANDLE, cbuf, "Tclsh", 0,
  186.                           MB_OK | MB_ICONEXCLAMATION | MB_APPLMODAL);
  187. #else
  188.             fprintf(stderr, "%s\n", interp->result);
  189. #endif
  190.     } else {
  191.         f = fopen(fullName, "r");
  192.         if (f != NULL) {
  193.         code = Tcl_EvalFile(interp, fullName);
  194.         if (code != TCL_OK) {
  195. #ifndef CLI_VERSION
  196.                 sprintf(cbuf, "%s\n", interp->result);
  197.                     WinMessageBox(HWND_DESKTOP, NULLHANDLE, cbuf, "Tclsh", 0,
  198.                                   MB_OK | MB_ICONEXCLAMATION | MB_APPLMODAL);
  199. #else
  200.                     fprintf(stderr, "%s\n", interp->result);
  201. #endif
  202.         }
  203.         fclose(f);
  204.         }
  205.     }
  206.     Tcl_DStringFree(&buffer);
  207.     }
  208.  
  209.     /*
  210.      * Create and display the console window.
  211.      */
  212.  
  213. #ifndef CLI_VERSION
  214.     hTerminal = CreateTerminal(TclOS2GetHAB(), interp);
  215.     if (hTerminal == NULLHANDLE) {
  216.         WinMessageBox(HWND_DESKTOP, NULLHANDLE, "Cannot create Terminal",
  217.                       "Tclsh", 0, MB_OK | MB_ERROR | MB_APPLMODAL);
  218.         /* Don't forget to cleanly exit PM */
  219.         PMShutdown();
  220.         return;
  221.     }
  222. #endif
  223.  
  224.     /*
  225.      * Process commands from stdin until there's an end-of-file.
  226.      */
  227.  
  228.     gotPartial = 0;
  229.     Tcl_DStringInit(&command);
  230.     inChannel = Tcl_GetStdChannel(TCL_STDIN);
  231.     outChannel = Tcl_GetStdChannel(TCL_STDOUT);
  232.     errChannel = Tcl_GetStdChannel(TCL_STDERR);
  233.     while (1) {
  234.         Tcl_DoOneEvent(TCL_ALL_EVENTS);
  235. #ifdef CLI_VERSION
  236.  
  237.     if (tty) {
  238.         char *promptCmd;
  239.  
  240.         promptCmd = Tcl_GetVar(interp,
  241.         gotPartial ? "tcl_prompt2" : "tcl_prompt1", TCL_GLOBAL_ONLY);
  242.         if (promptCmd == NULL) {
  243. defaultPrompt:
  244.         if (!gotPartial && outChannel) {
  245.             Tcl_Write(outChannel, "% ", 2);
  246.         }
  247.         } else {
  248.         code = Tcl_Eval(interp, promptCmd);
  249.         inChannel = Tcl_GetStdChannel(TCL_STDIN);
  250.         outChannel = Tcl_GetStdChannel(TCL_STDOUT);
  251.         errChannel = Tcl_GetStdChannel(TCL_STDERR);
  252.         if (code != TCL_OK) {
  253.             if (errChannel) {
  254.                 Tcl_Write(errChannel, interp->result, -1);
  255.                 Tcl_Write(errChannel, "\n", 1);
  256.             }
  257.             Tcl_AddErrorInfo(interp,
  258.                 "\n    (script that generates prompt)");
  259.             goto defaultPrompt;
  260.         }
  261.         }
  262.         if (outChannel) {
  263.             Tcl_Flush(outChannel);
  264.         }
  265.     }
  266.         if (!inChannel) {
  267.             goto done;
  268.         }
  269.         length = Tcl_Gets(inChannel, &command);
  270.         if (length < 0) {
  271.             goto done;
  272.         }
  273.         if ((length == 0) && Tcl_Eof(inChannel) && (!gotPartial)) {
  274.             goto done;
  275.         }
  276.  
  277.         /*
  278.          * Add the newline removed by Tcl_Gets back to the string.
  279.          */
  280.  
  281.         (void) Tcl_DStringAppend(&command, "\n", -1);
  282.  
  283.         cmd = Tcl_DStringValue(&command);
  284.         if (!Tcl_CommandComplete(cmd)) {
  285.             gotPartial = 1;
  286.             continue;
  287.         }
  288.  
  289.         gotPartial = 0;
  290.         code = Tcl_RecordAndEval(interp, cmd, 0);
  291.         inChannel = Tcl_GetStdChannel(TCL_STDIN);
  292.         outChannel = Tcl_GetStdChannel(TCL_STDOUT);
  293.         errChannel = Tcl_GetStdChannel(TCL_STDERR);
  294.         Tcl_DStringFree(&command);
  295.         if (code != TCL_OK) {
  296.             if (errChannel) {
  297.                 Tcl_Write(errChannel, interp->result, -1);
  298.                 Tcl_Write(errChannel, "\n", 1);
  299.             }
  300.         } else if (tty && (*interp->result != 0)) {
  301.             if (outChannel) {
  302.                 Tcl_Write(outChannel, interp->result, -1);
  303.                 Tcl_Write(outChannel, "\n", 1);
  304.             }
  305.         }
  306.  
  307.    #ifdef TCL_MEM_DEBUG
  308.     if (quitFlag) {
  309.         Tcl_DeleteInterp(interp);
  310.         Tcl_DumpActiveMemory(dumpFile);
  311.         /* Don't forget to cleanly exit PM */
  312.         PMShutdown();
  313.         exit(0);
  314.     }
  315.    #endif
  316. #endif
  317.     }
  318.  
  319.     /*
  320.      * Rather than calling exit, invoke the "exit" command so that
  321.      * users can replace "exit" with some other command to do additional
  322.      * cleanup on exit.  The Tcl_Eval call should never return.
  323.      */
  324.  
  325.     done:
  326.     /* Don't forget to cleanly exit PM */
  327.     PMShutdown();
  328.     sprintf(cbuf, "exit %d", exitCode);
  329.     Tcl_Eval(interp, cbuf);
  330. }
  331.  
  332. /*
  333.  *----------------------------------------------------------------------
  334.  *
  335.  * CheckmemCmd --
  336.  *
  337.  *    This is the command procedure for the "checkmem" command, which
  338.  *    causes the application to exit after printing information about
  339.  *    memory usage to the file passed to this command as its first
  340.  *    argument.
  341.  *
  342.  * Results:
  343.  *    Returns a standard Tcl completion code.
  344.  *
  345.  * Side effects:
  346.  *    None.
  347.  *
  348.  *----------------------------------------------------------------------
  349.  */
  350. #ifdef TCL_MEM_DEBUG
  351.  
  352.     /* ARGSUSED */
  353. static int
  354. CheckmemCmd(clientData, interp, argc, argv)
  355.     ClientData clientData;        /* Not used. */
  356.     Tcl_Interp *interp;            /* Interpreter for evaluation. */
  357.     int argc;                /* Number of arguments. */
  358.     char *argv[];            /* String values of arguments. */
  359. {
  360.     if (argc != 2) {
  361.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  362.         " fileName\"", (char *) NULL);
  363.     return TCL_ERROR;
  364.     }
  365.     strcpy(dumpFile, argv[1]);
  366.     quitFlag = 1;
  367.     return TCL_OK;
  368. }
  369. #endif
  370.  
  371. /*
  372.  *----------------------------------------------------------------------
  373.  *
  374.  * TclOS2Panic --
  375.  *
  376.  *    Display a message and exit.
  377.  *
  378.  * Results:
  379.  *    None.
  380.  *
  381.  * Side effects:
  382.  *    Exits the program.
  383.  *
  384.  *----------------------------------------------------------------------
  385.  */
  386.  
  387. void
  388. TclOS2Panic TCL_VARARGS_DEF(char *,arg1)
  389. {
  390.     va_list argList;
  391.     char buf[1024];
  392.     char *format;
  393.     
  394.     format = TCL_VARARGS_START(char *,arg1,argList);
  395.     vsprintf(buf, format, argList);
  396.  
  397. #ifdef DEBUG
  398.     printf("TclOS2Panic: %s\n", buf);
  399.     fflush(stdout);
  400.     fflush(stderr);
  401. #endif
  402.  
  403. #ifndef CLI_VERSION
  404.     /* Make sure pointer is not captured (for WinMessageBox) */
  405.     WinSetCapture(HWND_DESKTOP, NULLHANDLE);
  406.     WinAlarm(HWND_DESKTOP, WA_ERROR);
  407.     WinMessageBox(HWND_DESKTOP, NULLHANDLE, buf, "Fatal Error in Tclsh", 0,
  408.         MB_OK | MB_ERROR | MB_APPLMODAL);
  409.     PMShutdown();
  410. #else
  411.     fprintf(stderr, "FATAL: %s\n", buf);
  412. #endif
  413.     exit(1);
  414. }
  415.