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