home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / tcl / tclX6.5c / src / tclXstartup.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-12-19  |  17.5 KB  |  523 lines
  1. /*
  2.  * tclXstartup.c --
  3.  *
  4.  * Startup code for the Tcl shell and other interactive applications.  Also
  5.  * create special commands used just by Tcl shell features.
  6.  *-----------------------------------------------------------------------------
  7.  * Copyright 1992 Karl Lehenbauer and Mark Diekhans.
  8.  *
  9.  * Permission to use, copy, modify, and distribute this software and its
  10.  * documentation for any purpose and without fee is hereby granted, provided
  11.  * that the above copyright notice appear in all copies.  Karl Lehenbauer and
  12.  * Mark Diekhans make no representations about the suitability of this
  13.  * software for any purpose.  It is provided "as is" without express or
  14.  * implied warranty.
  15.  *-----------------------------------------------------------------------------
  16.  * $Id: tclXstartup.c,v 2.4 1992/11/19 15:29:29 markd Exp $
  17.  *-----------------------------------------------------------------------------
  18.  */
  19.  
  20. #include "tclExtdInt.h"
  21. #include "patchlevel.h"
  22.  
  23. extern char * etenv ();
  24.  
  25. extern char *optarg;
  26. extern int   optind, opterr;
  27.  
  28. typedef struct tclParms_t {
  29.     int       execFile;      /* Run the specified file. (no searching)       */
  30.     int       execCommand;   /* Execute the specified command.               */
  31.     unsigned  options;       /* Quick startup option.                        */
  32.     char     *execStr;       /* Command file or command to execute.          */
  33.     char    **tclArgv;       /* Arguments to pass to tcl script.             */
  34.     int       tclArgc;       /* Count of arguments to pass to tcl script.    */
  35.     char     *programName;   /* Name of program (less path).                 */
  36.     } tclParms_t;
  37.  
  38. /*
  39.  * Prototypes of internal functions.
  40.  */
  41. void
  42. ParseCmdArgs _ANSI_ARGS_((int          argc,
  43.                           char       **argv,
  44.                           tclParms_t  *tclParmsPtr));
  45.  
  46. int
  47. FindDefaultFile _ANSI_ARGS_((Tcl_Interp  *interp,
  48.                              char        *defaultFile));
  49.  
  50. int
  51. ProcessDefaultFile _ANSI_ARGS_((Tcl_Interp  *interp,
  52.                                 char        *defaultFile));
  53.  
  54. int
  55. ProcessInitFile _ANSI_ARGS_((Tcl_Interp  *interp));
  56.  
  57.  
  58. /*
  59.  *-----------------------------------------------------------------------------
  60.  *
  61.  * Tcl_ErrorAbort --
  62.  *
  63.  * Display error information and abort when an error is returned in the
  64.  * interp->result.
  65.  *
  66.  * Parameters:
  67.  *   o interp - A pointer to the interpreter, should contain the
  68.  *     error message in `result'.
  69.  *   o noStackDump - If TRUE, then the procedure call stack will not be
  70.  *     displayed.
  71.  *   o exitCode - The code to pass to exit.
  72.  *-----------------------------------------------------------------------------
  73.  */
  74. void
  75. Tcl_ErrorAbort (interp, noStackDump, exitCode)
  76.     Tcl_Interp  *interp;
  77.     int          noStackDump;
  78.     int          exitCode;
  79. {
  80.     char *errorStack;
  81.  
  82.     fflush (stdout);
  83.     fprintf (stderr, "Error: %s\n", interp->result);
  84.  
  85.     if (noStackDump == 0) {
  86.         errorStack = Tcl_GetVar (interp, "errorInfo", 1);
  87.         if (errorStack != NULL)
  88.             fprintf (stderr, "%s\n", errorStack);
  89.     }
  90.     exit (exitCode);
  91. }
  92.  
  93. /*
  94.  *-----------------------------------------------------------------------------
  95.  *
  96.  * ParseCmdArgs --
  97.  *
  98.  * Parse the arguments passed to the Tcl shell
  99.  *
  100.  * Parameters:
  101.  *   o argc, argv - Arguments passed to main.
  102.  *   o tclParmsPtr - Results of the parsed Tcl shell command line.
  103.  *-----------------------------------------------------------------------------
  104.  */
  105. static void
  106. ParseCmdArgs (argc, argv, tclParmsPtr)
  107.     int          argc;
  108.     char       **argv;
  109.     tclParms_t  *tclParmsPtr;
  110. {
  111.     char   *scanPtr, *programName;
  112.     int     programNameLen;
  113.     int     option;
  114.  
  115.     tclParmsPtr->execFile = FALSE;
  116.     tclParmsPtr->execCommand = FALSE;
  117.     tclParmsPtr->options = 0;
  118.     tclParmsPtr->execStr = NULL;
  119.  
  120.     /*
  121.      * Determine file name (less directories) that the Tcl interpreter is
  122.      * being run under.
  123.      */
  124.     scanPtr = programName = argv[0];
  125.     while (*scanPtr != '\0') {
  126.         if (*scanPtr == '/')
  127.             programName = scanPtr + 1;
  128.         scanPtr++;
  129.     }
  130.     tclParmsPtr->programName = programName;
  131.     programNameLen = strlen (programName);
  132.     
  133.     /*
  134.      * Scan arguments looking for flags to process here rather than to pass
  135.      * on to the scripts.  The '-c' or '-f' must also be the last option to
  136.      * allow for script arguments starting with `-'.
  137.      */
  138.     while ((option = getopt (argc, argv, "qc:f:un")) != -1) {
  139.         switch (option) {
  140.             case 'q':
  141.                 if (tclParmsPtr->options & TCLSH_QUICK_STARTUP)
  142.                     goto usageError;
  143.                 tclParmsPtr->options |= TCLSH_QUICK_STARTUP;
  144.                 break;
  145.             case 'n':
  146.                 if (tclParmsPtr->options & TCLSH_NO_STACK_DUMP)
  147.                     goto usageError;
  148.                 tclParmsPtr->options |= TCLSH_NO_STACK_DUMP;
  149.                 break;
  150.             case 'c':
  151.                 tclParmsPtr->execCommand = TRUE;
  152.                 tclParmsPtr->execStr = optarg;
  153.                 goto exitParse;
  154.             case 'f':
  155.                 tclParmsPtr->execFile = TRUE;
  156.                 tclParmsPtr->execStr = optarg;
  157.                 goto exitParse;
  158.             case 'u':
  159.             default:
  160.                 goto usageError;
  161.         }
  162.     }
  163.     exitParse:
  164.   
  165.     /*
  166.      * If neither `-c' nor `-f' were specified and at least one parameter
  167.      * is supplied, then if is the file to execute.  The rest of the arguments
  168.      * are passed to the script.  Check for '--' as the last option, this also
  169.      * is a terminator for the file to execute.
  170.      */
  171.     if ((!tclParmsPtr->execCommand) && (!tclParmsPtr->execFile) &&
  172.         (optind != argc) && !STREQU (argv [optind-1], "--")) {
  173.         tclParmsPtr->execFile = TRUE;
  174.         tclParmsPtr->execStr = argv [optind];
  175.         optind++;
  176.     }
  177.  
  178.     tclParmsPtr->tclArgv = &argv [optind];
  179.     tclParmsPtr->tclArgc = argc - optind;
  180.     return;
  181.  
  182. usageError:
  183.     fprintf (stderr, "usage: %s %s\n", argv [0],
  184.              "[-qun] [[-f] script]|[-c command] [args]");
  185.     exit (1);
  186. }
  187.  
  188. /*
  189.  *-----------------------------------------------------------------------------
  190.  * FindDefaultFile --
  191.  *
  192.  *   Find the Tcl default file.  If is looked for in the following order:
  193.  *       o A environment variable named `TCLDEFAULT'.
  194.  *       o The specified defaultFile (which normally has an version number
  195.  *         appended.
  196.  *   A tcl variable `TCLDEFAULT', will contain the path of the default file
  197.  *   to use after this procedure is executed, or a null string if it is not
  198.  *   found.
  199.  * Parameters
  200.  *   o interp (I) - A pointer to the interpreter.
  201.  *   o defaultFile (I) - The file name of the default file to use, it
  202.  *     normally contains a version number.
  203.  * Returns:
  204.  *     TCL_OK if all is ok, TCL_ERROR if a error occured.
  205.  *-----------------------------------------------------------------------------
  206.  */
  207. static int
  208. FindDefaultFile (interp, defaultFile)
  209.     Tcl_Interp  *interp;
  210.     char        *defaultFile;
  211. {
  212.     char        *defaultFileToUse;
  213.     struct stat  statBuf;
  214.  
  215.     if ((defaultFileToUse = getenv ("TCLDEFAULT")) == NULL)
  216.         defaultFileToUse = defaultFile;
  217.  
  218.     if (stat (defaultFileToUse, &statBuf) < 0)
  219.         defaultFileToUse = "";
  220.     if (Tcl_SetVar (interp, "TCLDEFAULT", defaultFileToUse,
  221.                     TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG) == NULL)
  222.         return TCL_ERROR;
  223.     else
  224.         return TCL_OK;
  225. }
  226.  
  227. /*
  228.  *-----------------------------------------------------------------------------
  229.  * ProcessDefaultFile --
  230.  *
  231.  *   Process the Tcl default file and TclInit files.  The default file
  232.  * is the only file at a fixed path. It is a script file that usaually 
  233.  * defines a variable "TCLINIT", which has the path of the  full
  234.  * initialization file. The default file can also set things such as path
  235.  * variables.  If the TCLINIT variable is set, that file is then evaluated.
  236.  * If usually does the full Tcl initialization.
  237.  *
  238.  * Parameters
  239.  *   o interp  (I) - A pointer to the interpreter.
  240.  *   o defaultFile (I) - The file name of the default file to use, it
  241.  *     normally contains a version number.
  242.  * Returns:
  243.  *   TCL_OK if all is ok, TCL_ERROR if an error occured.
  244.  *-----------------------------------------------------------------------------
  245.  */
  246. static int
  247. ProcessDefaultFile (interp, defaultFile)
  248.     Tcl_Interp  *interp;
  249.     char        *defaultFile;
  250. {
  251.     char *defaultFileToUse;
  252.  
  253.     defaultFileToUse = Tcl_GetVar (interp, "TCLDEFAULT", 1);
  254.     if (*defaultFileToUse == '\0') {
  255.         Tcl_AppendResult (interp,
  256.                           "Can't access Tcl default file,\n",
  257.                           "  Located in one of the following ways:\n",
  258.                           "    Environment variable: `TCLDEFAULT' or,\n",
  259.                           "    File `", defaultFile, "'.\n", 
  260.                           (char *) NULL);
  261.         return TCL_ERROR;
  262.     }
  263.     if (Tcl_EvalFile (interp, defaultFileToUse) != TCL_OK)
  264.         return TCL_ERROR;
  265.     Tcl_ResetResult (interp);
  266.  
  267.     return TCL_OK;
  268. }
  269.  
  270. /*
  271.  *-----------------------------------------------------------------------------
  272.  * ProcessInitFile --
  273.  *
  274.  *    Process the Tcl init file, its abolute patch should be contained in
  275.  * a Tcl variable "TCLINIT".  If the variable is not found, the file will
  276.  * not be evaulated.
  277.  *
  278.  * Parameters
  279.  *   o interp  (I) - A pointer to the interpreter.
  280.  * Returns:
  281.  *   TCL_OK if all is ok, TCL_ERROR if an error occured.
  282.  *-----------------------------------------------------------------------------
  283.  */
  284. static int
  285. ProcessInitFile (interp)
  286.     Tcl_Interp  *interp;
  287. {
  288.     char *initFile;
  289.  
  290.     initFile = Tcl_GetVar (interp, "TCLINIT", 1);
  291.     if (initFile != NULL) {
  292.         if (Tcl_EvalFile (interp, initFile) != TCL_OK)
  293.             return TCL_ERROR;
  294.     }
  295.     Tcl_ResetResult (interp);
  296.     return TCL_OK;
  297. }
  298.  
  299. /*
  300.  *-----------------------------------------------------------------------------
  301.  *
  302.  * Tcl_ShellEnvInit --
  303.  *
  304.  *   Process the Tcl default file.  The default file is the only file at a
  305.  * fixed path. It is a script file that usaually defines a variable "TCLINIT",
  306.  * which has the path of the full initialization file. The default file can
  307.  * also set things such as path variables.  
  308.  *
  309.  * If this is an interactive Tcl session, SIGINT is set to generate a Tcl
  310.  * error.
  311.  *
  312.  * Parameters
  313.  *   o interp - A pointer to the interpreter.
  314.  *   o options - Flags to control the behavior of this routine, the following
  315.  *     option is supported:
  316.  *       o TCLSH_QUICK_STARTUP - Don't source the default file or Tcl init
  317.  *         file.
  318.  *       o TCLSH_ABORT_STARTUP_ERR - If set, abort the process if an error
  319.  *         occurs.
  320.  *       o TCLSH_NO_INIT_FILE - If set, process the default file, but not the
  321.  *         init file.  This can be used to make the default file do all
  322.  *         initialization.
  323.  *       o TCLSH_NO_STACK_DUMP - If an error occurs, don't dump out the
  324.  *         procedure call stack, just print an error message.
  325.  *   o programName (I) - The name of the program being executed, usually
  326.  *     taken from the main argv [0].  Used to set the Tcl variable.  If NULL
  327.  *     then the variable will not be set.
  328.  *   o argc, argv (I) - Arguments to pass to the program in a Tcl list variable
  329.  *     `argv'.  Argv [0] should contain the first argument not the program
  330.  *     name.  If argv is NULL, then the variable will not be set.
  331.  *   o interactive (I) - The value to assign to the `interactiveSession' Tcl
  332.  *     variable. TRUE if an interactive Tcl command loop will be entered,
  333.  *     FALSE if a script will be executed .  The function does not enter the
  334.  *     command loop, it just sets the variable.
  335.  *   o defaultFile (I) - The file name of the default file to use.  If NULL,
  336.  *     then the standard Tcl default file is used, which is formed from a
  337.  *     location specified at compile time and the Extended Tcl version
  338.  *     number.
  339.  * Notes:
  340.  *   The variables tclAppName, tclAppLongName, tclAppVersion 
  341.  * must be set before calling thus routine if special values are desired.
  342.  *
  343.  * Returns:
  344.  *   TCL_OK if all is ok, TCL_ERROR if an error occured.
  345.  *-----------------------------------------------------------------------------
  346.  */
  347. int
  348. Tcl_ShellEnvInit (interp, options, programName, argc, argv, interactive,
  349.                   defaultFile)
  350.     Tcl_Interp  *interp;
  351.     unsigned     options;
  352.     CONST char  *programName; 
  353.     int          argc;
  354.     CONST char **argv;
  355.     int          interactive;
  356.     CONST char  *defaultFile;
  357. {
  358.     int   result = TCL_OK;
  359.     char *defaultFilePath;
  360.  
  361.     /*
  362.      * Setup patch to default file, if not specified.
  363.      */
  364.     if (defaultFile == NULL) {
  365.         defaultFilePath = ckalloc (strlen (TCL_DEFAULT) +
  366.                                    strlen (TCL_VERSION) +
  367.                                    strlen (TCL_EXTD_VERSION_SUFFIX) + 1);
  368.         strcpy (defaultFilePath, TCL_DEFAULT);
  369.         strcat (defaultFilePath, TCL_VERSION);
  370.         strcat (defaultFilePath, TCL_EXTD_VERSION_SUFFIX);
  371.     } else {
  372.         defaultFilePath = (char *) defaultFile;
  373.     }
  374.  
  375.     if (programName != NULL) {
  376.         if (Tcl_SetVar (interp, "programName", (char *) programName,
  377.                         TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG) == NULL)
  378.             goto errorExit;
  379.     }
  380.  
  381.     if (argv != NULL) {
  382.         char *args;
  383.  
  384.         args = Tcl_Merge (argc, (char **) argv);
  385.         if (Tcl_SetVar (interp, "argv", args,
  386.                         TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG) == NULL)
  387.             result = TCL_ERROR;
  388.         ckfree (args);
  389.         if (result != TCL_OK)
  390.             goto errorExit;
  391.     }
  392.     if (Tcl_SetVar (interp, "interactiveSession", interactive ? "1" : "0",
  393.                     TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG) == NULL)
  394.         goto errorExit;
  395.  
  396.     tclxVersion = ckalloc (strlen (TCL_VERSION) + 
  397.                            strlen (TCL_EXTD_VERSION_SUFFIX) + 1);
  398.     strcpy (tclxVersion, TCL_VERSION);
  399.     strcat (tclxVersion, TCL_EXTD_VERSION_SUFFIX);
  400.  
  401. #ifdef PATCHLEVEL
  402.     tclxPatchlevel = PATCHLEVEL;
  403. #else
  404.     tclxPatchlevel = 0;
  405. #endif
  406.  
  407.     /*
  408.      * Set application specific values to return from the infox if they
  409.      * have not been set.
  410.      */
  411.     if (tclAppName == NULL)
  412.         tclAppName = "TclX";
  413.     if (tclAppLongname == NULL)
  414.         tclAppLongname = "Extended Tcl";
  415.     if (tclAppVersion == NULL)
  416.         tclAppVersion = tclxVersion;
  417.  
  418.     /*
  419.      * Locate the default file and save in Tcl var TCLDEFAULT.  If not quick
  420.      * startup, process the Tcl default file and execute the Tcl
  421.      * initialization file.
  422.      */
  423.     if (FindDefaultFile (interp, (char *) defaultFilePath) != TCL_OK)
  424.         goto errorExit;
  425.     if (!(options & TCLSH_QUICK_STARTUP)) {
  426.         if (ProcessDefaultFile (interp, defaultFilePath) != TCL_OK)
  427.             goto errorExit;
  428.         if (!(options & TCLSH_NO_INIT_FILE)) {
  429.             if (ProcessInitFile (interp) != TCL_OK)
  430.                 goto errorExit;
  431.         }
  432.     }
  433.     if (defaultFilePath != defaultFile)
  434.         ckfree (defaultFilePath);
  435.  
  436.     if (interactive)
  437.         Tcl_SetupSigInt ();
  438.  
  439.     return TCL_OK;
  440.  
  441. errorExit:
  442.     if (defaultFilePath != defaultFile)
  443.         ckfree (defaultFilePath);
  444.     if (options & TCLSH_ABORT_STARTUP_ERR)
  445.         Tcl_ErrorAbort (interp, options & TCLSH_NO_STACK_DUMP, 255);
  446.     return TCL_ERROR;
  447. }
  448.  
  449. /*
  450.  *-----------------------------------------------------------------------------
  451.  *
  452.  * Tcl_Startup --
  453.  *
  454.  *    Initializes the Tcl extended environment.  This function processes the
  455.  * standard command line arguments and locates the Tcl default file.  It then
  456.  * sources the default file and initialization file pointed to by the default
  457.  * file.  Either an interactive command loop is created or a Tcl script file
  458.  * is executed depending on the command line.  This functions calls
  459.  * Tcl_ShellEnvInit, so it should not be called separately.
  460.  *
  461.  * Parameters
  462.  *   o interp - A pointer to the interpreter.
  463.  *   o argc, argv - Arguments passed to main for the command line.
  464.  *   o defaultFile (I) - The file name of the default file to use.  If NULL,
  465.  *     then the standard Tcl default file is used, which is formed from a
  466.  *     location specified at compile time and the Extended Tcl version
  467.  *     number.
  468.  *   o options (I) - Options that control startup behavior.  None are
  469.  *     currently defined.
  470.  * Notes:
  471.  *   The variables tclAppName, tclAppLongName, tclAppVersion 
  472.  * must be set before calling thus routine if special values are desired.
  473.  *-----------------------------------------------------------------------------
  474.  */
  475. void
  476. Tcl_Startup (interp, argc, argv, defaultFile, options)
  477.     Tcl_Interp  *interp;
  478.     int          argc;
  479.     CONST char **argv;
  480.     CONST char  *defaultFile;
  481.     unsigned     options;
  482. {
  483.     char       *cmdBuf;
  484.     tclParms_t  tclParms;
  485.     int         result;
  486.  
  487.     /*
  488.      * Process the arguments.
  489.      */
  490.     ParseCmdArgs (argc, (char **) argv, &tclParms);
  491.  
  492.     if (Tcl_ShellEnvInit (interp,
  493.                           tclParms.options,
  494.                           tclParms.programName,
  495.                           tclParms.tclArgc, tclParms.tclArgv,
  496.                           (tclParms.execStr == NULL),
  497.                           defaultFile) != TCL_OK)
  498.         goto errorAbort;
  499.  
  500.     /*
  501.      * If the invoked tcl interactively, give the user an interactive session,
  502.      * otherwise, source the command file or execute the specified command.
  503.      */
  504.     if (tclParms.execFile) {
  505.         result = Tcl_EvalFile (interp, tclParms.execStr);
  506.         if (result != TCL_OK)
  507.             goto errorAbort;
  508.     } else if (tclParms.execCommand) {
  509.         result = Tcl_Eval (interp, tclParms.execStr, 0, NULL);
  510.         if (result != TCL_OK)
  511.             goto errorAbort;
  512.     } else {
  513.         Tcl_CommandLoop (interp, stdin, stdout, tclShellCmdEvalProc, 0);
  514.     }
  515.  
  516.     Tcl_ResetResult (interp);
  517.     return;
  518.  
  519. errorAbort:
  520.     Tcl_ErrorAbort (interp, tclParms.options & TCLSH_NO_STACK_DUMP, 255);
  521. }
  522.  
  523.