git.zerfleddert.de Git - micropolis/blob - src/tclx/src/tclxstup.c

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