home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / tcltk805.zip / tcl805s.zip / tcl8.0.5 / os2 / tclOS2Main.c < prev    next >
C/C++ Source or Header  |  2001-02-09  |  14KB  |  437 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-2001 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 "tclOS2Int.h"
  15.  
  16. static Tcl_Interp *interp;     /* Interpreter for application. */
  17.  
  18. #ifdef TCL_MEM_DEBUG
  19. static char dumpFile[100];     /* Records where to dump memory allocation
  20.                                 * information. */
  21. static int quitFlag = 0;       /* 1 means the "checkmem" command was
  22.                                 * invoked, so the application should quit
  23.                                 * and dump memory allocation information. */
  24. #endif
  25.  
  26. /*
  27.  * Forward references for procedures defined later in this file:
  28.  */
  29.  
  30. static void TclOS2Panic TCL_VARARGS(char *,format);
  31. #ifdef TCL_MEM_DEBUG
  32. static int CheckmemCmd _ANSI_ARGS_((ClientData clientData,
  33.                 Tcl_Interp *interp, int argc, char *argv[]));
  34. #endif
  35.  
  36.  
  37. /*
  38.  *----------------------------------------------------------------------
  39.  *
  40.  * Tcl_Main --
  41.  *
  42.  *    Main program for tclsh and most other Tcl-based applications.
  43.  *
  44.  * Results:
  45.  *    None. This procedure never returns (it exits the process when
  46.  *    it's done.
  47.  *
  48.  * Side effects:
  49.  *    This procedure initializes the Tcl world and then starts
  50.  *    interpreting commands;  almost anything could happen, depending
  51.  *    on the script being interpreted.
  52.  *
  53.  *----------------------------------------------------------------------
  54.  */
  55.  
  56. #ifndef CLI_VERSION
  57. static char consoleScript[] = "\n\
  58. set loaded [info loaded {}]\n\
  59. if ![auto_load tkConInit] {\n\
  60.   error \"cannot start tkcon\"\n\
  61. }\n\
  62. foreach pkg $loaded {\n\
  63.   set name [lindex $pkg 1]\n\
  64.   set version [package require $name]\n\
  65.   slave eval package require $name $version\n\
  66.   unset name version\n\
  67. }\n\
  68. catch {unset pkg}\n\
  69. unset loaded\n\
  70. ";
  71. #endif
  72.  
  73. void
  74. Tcl_Main(argc, argv, appInitProc)
  75.     int argc;                /* Number of arguments. */
  76.     char **argv;            /* Array of argument strings. */
  77.     Tcl_AppInitProc *appInitProc;    /* Application-specific initialization
  78.                      * procedure to call after most
  79.                      * initialization but before starting
  80.                      * to execute commands. */
  81. {
  82.     Tcl_Obj *prompt1NamePtr = NULL;
  83.     Tcl_Obj *prompt2NamePtr = NULL;
  84.     Tcl_Obj *commandPtr = NULL;
  85.     char cbuf[1000], *args, *fileName;
  86.     int code, gotPartial, tty;
  87.     int exitCode = 0;
  88.     Tcl_Channel inChannel, outChannel;
  89.     Tcl_Obj *resultPtr;
  90.     char *bytes;
  91.     int length;
  92.     Tcl_Channel errChannel;
  93.     BOOL usePm = TclOS2GetUsePm();
  94.     HWND hTerminal;
  95.  
  96.     /* Set Panic procedure */
  97.     Tcl_SetPanicProc(TclOS2Panic);
  98.  
  99.     Tcl_FindExecutable(argv[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(cbuf, "%d", argc-1);
  124.     Tcl_SetVar(interp, "argc", cbuf, 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 ((*appInitProc)(interp) != TCL_OK) {
  141.         if (usePm) {
  142.             sprintf(cbuf, "application-specific initialization failed: %s\n",
  143.                     interp->result);
  144.             WinMessageBox(HWND_DESKTOP, NULLHANDLE, cbuf, "Tclsh",
  145.                           0, MB_OK | MB_ICONEXCLAMATION | MB_APPLMODAL);
  146.         } else {
  147.             errChannel = Tcl_GetStdChannel(TCL_STDERR);
  148.             if (errChannel) {
  149.                 Tcl_Write(errChannel,
  150.                         "application-specific initialization failed: ", -1);
  151.                 Tcl_Write(errChannel, Tcl_GetStringResult(interp), -1);
  152.                 Tcl_Write(errChannel, "\n", 1);
  153.             }
  154.         }
  155.     }
  156.  
  157.     /*
  158.      * If a script file was specified then just source that file
  159.      * and quit.
  160.      */
  161.  
  162.     if (fileName != NULL) {
  163.         code = Tcl_EvalFile(interp, fileName);
  164.         if (code != TCL_OK) {
  165.             if (usePm) {
  166.                 sprintf(cbuf, "%s\n", interp->result);
  167.                 WinMessageBox(HWND_DESKTOP, NULLHANDLE, cbuf, "Tclsh", 0,
  168.                               MB_OK | MB_ERROR | MB_APPLMODAL);
  169.             } else {
  170.                 errChannel = Tcl_GetStdChannel(TCL_STDERR);
  171.                 if (errChannel) {
  172.                     /*
  173.                      * The following statement guarantees that the errorInfo
  174.                      * variable is set properly.
  175.                      */
  176.  
  177.                     Tcl_AddErrorInfo(interp, "");
  178.                     Tcl_Write(errChannel,
  179.                             Tcl_GetVar(interp, "errorInfo",TCL_GLOBAL_ONLY),-1);
  180.                     Tcl_Write(errChannel, "\n", 1);
  181.             }
  182.             }
  183.             exitCode = 1;
  184.         }
  185.         goto done;
  186.     }
  187.  
  188.     /*
  189.      * We're running interactively.  Source a user-specific startup
  190.      * file if the application specified one and if the file exists.
  191.      */
  192.  
  193.     Tcl_SourceRCFile(interp);
  194.  
  195.     /*
  196.      * If standard input is a terminal-like device and the variable
  197.      * NoTkCon is not set, try to start up TkCon. If this fails,
  198.      * just continue with the original console.
  199.      */
  200.  
  201.     if (usePm) {
  202.         if (tty && !Tcl_GetVar(interp, "NoTkCon", TCL_GLOBAL_ONLY) &&
  203.                 Tcl_GlobalEval(interp, consoleScript) == TCL_OK) {
  204.             while (Tcl_DoOneEvent(0)) {
  205.                 /* empty body loop */
  206.             }
  207.             exitCode = 0;
  208.             goto done;
  209.         }
  210.         /*
  211.          * Create and display the console window.
  212.          */
  213.  
  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.             TclOS2PMShutdown();
  220.             return;
  221.         }
  222.     }
  223.  
  224.     /*
  225.      * Process commands from stdin until there's an end-of-file.
  226.      */
  227.  
  228.     commandPtr = Tcl_NewObj();
  229.     Tcl_IncrRefCount(commandPtr);
  230.     prompt1NamePtr = Tcl_NewStringObj("tcl_prompt1", -1);
  231.     Tcl_IncrRefCount(prompt1NamePtr);
  232.     prompt2NamePtr = Tcl_NewStringObj("tcl_prompt2", -1);
  233.     Tcl_IncrRefCount(prompt2NamePtr);
  234.  
  235.     inChannel = Tcl_GetStdChannel(TCL_STDIN);
  236.     outChannel = Tcl_GetStdChannel(TCL_STDOUT);
  237.     gotPartial = 0;
  238.     while (1) {
  239.         if (usePm) {
  240.            Tcl_DoOneEvent(0);
  241.         } else {
  242.             if (tty) {
  243.                 Tcl_Obj *promptCmdPtr;
  244.  
  245.                 promptCmdPtr = Tcl_ObjGetVar2(interp,
  246.                         (gotPartial? prompt2NamePtr : prompt1NamePtr),
  247.                         (Tcl_Obj *) NULL, TCL_GLOBAL_ONLY);
  248.                 if (promptCmdPtr == NULL) {
  249. defaultPrompt:
  250.                     if (!gotPartial && outChannel) {
  251.                         Tcl_Write(outChannel, "% ", 2);
  252.                     }
  253.                 } else {
  254.                     code = Tcl_EvalObj(interp, promptCmdPtr);
  255.                     inChannel = Tcl_GetStdChannel(TCL_STDIN);
  256.                     outChannel = Tcl_GetStdChannel(TCL_STDOUT);
  257.                     errChannel = Tcl_GetStdChannel(TCL_STDERR);
  258.                     if (code != TCL_OK) {
  259.                         if (errChannel) {
  260.                                 resultPtr = Tcl_GetObjResult(interp);
  261.                                 bytes = Tcl_GetStringFromObj(resultPtr,&length);
  262.                                 Tcl_Write(errChannel, bytes, length);
  263.                                 Tcl_Write(errChannel, "\n", 1);
  264.                         }
  265.                         Tcl_AddErrorInfo(interp,
  266.                                         "\n    (script that generates prompt)");
  267.                         goto defaultPrompt;
  268.                     } else if (*interp->result && outChannel) {
  269.                         Tcl_Write(outChannel, interp->result,
  270.                                   strlen(interp->result));
  271.                     }
  272.                 }
  273.                 if (outChannel) {
  274.                     Tcl_Flush(outChannel);
  275.                 }
  276.             }
  277.             if (!inChannel) {
  278.                 goto done;
  279.             }
  280.             length = Tcl_GetsObj(inChannel, commandPtr);
  281.             if (length < 0) {
  282.                 goto done;
  283.             }
  284.             if ((length == 0) && Tcl_Eof(inChannel) && (!gotPartial)) {
  285.                 goto done;
  286.             }
  287.  
  288.             /*
  289.              * Add the newline removed by Tcl_GetsObj back to the string.
  290.              */
  291.  
  292.             Tcl_AppendToObj(commandPtr, "\n", 1);
  293.             if (!TclObjCommandComplete(commandPtr)) {
  294.                 gotPartial = 1;
  295.                 continue;
  296.             }
  297.  
  298.             gotPartial = 0;
  299.             code = Tcl_RecordAndEvalObj(interp, commandPtr, 0);
  300.             inChannel = Tcl_GetStdChannel(TCL_STDIN);
  301.             outChannel = Tcl_GetStdChannel(TCL_STDOUT);
  302.             errChannel = Tcl_GetStdChannel(TCL_STDERR);
  303.             Tcl_SetObjLength(commandPtr, 0);
  304.             if (code != TCL_OK) {
  305.                 if (errChannel) {
  306.                     resultPtr = Tcl_GetObjResult(interp);
  307.                     bytes = Tcl_GetStringFromObj(resultPtr, &length);
  308.                     Tcl_Write(errChannel, bytes, length);
  309.                     Tcl_Write(errChannel, "\n", 1);
  310.                 }
  311.             } else if (tty) {
  312.                 resultPtr = Tcl_GetObjResult(interp);
  313.                 bytes = Tcl_GetStringFromObj(resultPtr, &length);
  314.                 if ((length > 0) && outChannel) {
  315.                     Tcl_Write(outChannel, bytes, length);
  316.                     Tcl_Write(outChannel, "\n", 1);
  317.                 }
  318.             }
  319.  
  320. #ifdef TCL_MEM_DEBUG
  321.             if (quitFlag) {
  322.                 Tcl_DecrRefCount(commandPtr);
  323.                 Tcl_DecrRefCount(prompt1NamePtr);
  324.                 Tcl_DecrRefCount(prompt2NamePtr);
  325.                 Tcl_DeleteInterp(interp);
  326.                 Tcl_Exit(0);
  327.             }
  328. #endif
  329.  
  330.         }
  331.     }
  332.  
  333.     /*
  334.      * Rather than calling exit, invoke the "exit" command so that
  335.      * users can replace "exit" with some other command to do additional
  336.      * cleanup on exit.  The Tcl_Eval call should never return.
  337.      */
  338.  
  339.     done:
  340.     if (commandPtr != NULL) {
  341.         Tcl_DecrRefCount(commandPtr);
  342.     }
  343.     if (prompt1NamePtr != NULL) {
  344.         Tcl_DecrRefCount(prompt1NamePtr);
  345.     }
  346.     if (prompt2NamePtr != NULL) {
  347.         Tcl_DecrRefCount(prompt2NamePtr);
  348.     }
  349.     sprintf(cbuf, "exit %d", exitCode);
  350.     Tcl_Eval(interp, cbuf);
  351. }
  352.  
  353. /*
  354.  *----------------------------------------------------------------------
  355.  *
  356.  * CheckmemCmd --
  357.  *
  358.  *    This is the command procedure for the "checkmem" command, which
  359.  *    causes the application to exit after printing information about
  360.  *    memory usage to the file passed to this command as its first
  361.  *    argument.
  362.  *
  363.  * Results:
  364.  *    Returns a standard Tcl completion code.
  365.  *
  366.  * Side effects:
  367.  *    None.
  368.  *
  369.  *----------------------------------------------------------------------
  370.  */
  371. #ifdef TCL_MEM_DEBUG
  372.  
  373.     /* ARGSUSED */
  374. static int
  375. CheckmemCmd(clientData, interp, argc, argv)
  376.     ClientData clientData;        /* Not used. */
  377.     Tcl_Interp *interp;            /* Interpreter for evaluation. */
  378.     int argc;                /* Number of arguments. */
  379.     char *argv[];            /* String values of arguments. */
  380. {
  381.     if (argc != 2) {
  382.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  383.         " fileName\"", (char *) NULL);
  384.     return TCL_ERROR;
  385.     }
  386.     strcpy(dumpFile, argv[1]);
  387.     quitFlag = 1;
  388.     return TCL_OK;
  389. }
  390. #endif
  391.  
  392. /*
  393.  *----------------------------------------------------------------------
  394.  *
  395.  * TclOS2Panic --
  396.  *
  397.  *    Display a message and exit.
  398.  *
  399.  * Results:
  400.  *    None.
  401.  *
  402.  * Side effects:
  403.  *    Exits the program.
  404.  *
  405.  *----------------------------------------------------------------------
  406.  */
  407.  
  408. void
  409. TclOS2Panic TCL_VARARGS_DEF(char *,arg1)
  410. {
  411.     va_list argList;
  412.     char buf[1024];
  413.     char *format;
  414.     
  415.     format = TCL_VARARGS_START(char *,arg1,argList);
  416.     vsprintf(buf, format, argList);
  417.  
  418. #ifdef VERBOSE
  419.     printf("TclOS2Panic: %s\n", buf);
  420.     fflush(stdout);
  421.     fflush(stderr);
  422. #endif
  423.  
  424. #ifndef CLI_VERSION
  425.     /* Make sure pointer is not captured (for WinMessageBox) */
  426.     WinSetCapture(HWND_DESKTOP, NULLHANDLE);
  427.     WinAlarm(HWND_DESKTOP, WA_ERROR);
  428.     WinMessageBox(HWND_DESKTOP, NULLHANDLE, buf, "Fatal Error in Tclsh", 0,
  429.                   MB_OK | MB_ERROR | MB_APPLMODAL);
  430.     TclOS2PMShutdown();
  431. #else
  432.     fprintf(stderr, "FATAL: %s\n", buf);
  433.     TclOS2PMShutdown();
  434. #endif
  435.     exit(1);
  436. }
  437.