home *** CD-ROM | disk | FTP | other *** search
/ Complete Linux / Complete Linux.iso / docs / devel / tcl / tclx7_31.z / tclx7_31 / tcldev / tclX7.3a-p1 / src / tclXshell.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-01-23  |  9.5 KB  |  302 lines
  1. /*
  2.  * tclXshell.c --
  3.  *
  4.  * Support code for the Extended Tcl shell.
  5.  *-----------------------------------------------------------------------------
  6.  * Copyright 1991-1993 Karl Lehenbauer and Mark Diekhans.
  7.  *
  8.  * Permission to use, copy, modify, and distribute this software and its
  9.  * documentation for any purpose and without fee is hereby granted, provided
  10.  * that the above copyright notice appear in all copies.  Karl Lehenbauer and
  11.  * Mark Diekhans make no representations about the suitability of this
  12.  * software for any purpose.  It is provided "as is" without express or
  13.  * implied warranty.
  14.  *-----------------------------------------------------------------------------
  15.  * $Id: tclXshell.c,v 3.3 1994/01/11 04:20:30 markd Exp $
  16.  *-----------------------------------------------------------------------------
  17.  */
  18.  
  19. #include "tclExtdInt.h"
  20.  
  21. extern char *optarg;
  22. extern int   optind, opterr;
  23.  
  24. static char  exitCmd [] = "exit";
  25. static char *TCLXENV = "TCLXENV";
  26.  
  27.  
  28. /*
  29.  * Prototypes of internal functions.
  30.  */
  31. static void
  32. ParseCmdLine _ANSI_ARGS_((Tcl_Interp   *interp,
  33.                           int           argc,
  34.                           char        **argv));
  35.  
  36. /*
  37.  *-----------------------------------------------------------------------------
  38.  *
  39.  * ParseCmdLine --
  40.  *
  41.  *   Parse the command line for the TclX shell ("tcl") and similar programs.
  42.  * This sets Tcl variables and returns, no other action is taken at this
  43.  * time.  The following Tcl variables are initialized by this routine:
  44.  *
  45.  *   o argv0 -  The name of the Tcl program specified on the command line or
  46.  *     the name that the Tcl shell was invoked under if no program was
  47.  *     specified.
  48.  *   o argc - Contains a count of the number of argv arguments (0 if none).
  49.  *   o argv- A list containing the arguments passed in from the command line,
  50.  *     excluding arguments used by the Tcl shell.  The first element is the
  51.  *     first passed argument, not the program name.
  52.  *   o tcl_interactive - Set to 1 if Tcl shell is invoked interactively, or
  53.  *     0 if the Tcl shell is directly executing a script.
  54.  *   o TCLXENV(evalCmd) - Command to eval, as specified by the -c flag.
  55.  *   o TCLXENV(evalFile) - File specified on the command to evaluate rather
  56.  *     than go interactive.
  57.  *   o TCLXENV(quick) - If defined, the -q for quick startup flag was
  58.  *     specified.
  59.  *   o TCLXENV(noDump) - If defined, the -n for no stack dump on error flag
  60.  *     was specified.
  61.  *
  62.  * This function should be called before any application or package specific
  63.  * initialization.  It aborts if an error occurs processing the command line.
  64.  *
  65.  * Parameters:
  66.  *   o interp - A pointer to the interpreter.
  67.  *   o argc, argv - Arguments passed to main for the command line.
  68.  * Notes:
  69.  *   The variables tclAppName, tclAppLongName, tclAppVersion must be set
  70.  * before calling thus routine if special values are desired.
  71.  *-----------------------------------------------------------------------------
  72.  */
  73. static void
  74. ParseCmdLine (interp, argc, argv)
  75.     Tcl_Interp   *interp;
  76.     int           argc;
  77.     char        **argv;
  78. {
  79.     char  *scanPtr, *tclArgv, *errorStack, numBuf [32];
  80.     int    option;
  81.     char  *evalFile = NULL;
  82.     char  *evalCmd  = NULL;
  83.     int    quick    = FALSE;
  84.     int    noDump   = FALSE;
  85.  
  86.     /*
  87.      * GNU libc redefined the behavior of getopt so that it attempts to
  88.      * do argument reordering.  This really messes up the TclX command
  89.      * line parser, since it stops parsing after the command or file so
  90.      * that the script itself can have "-" options or what ever it
  91.      * wants.  I wish they would have made the default behavior compatible
  92.      * with everyone else's getopt.
  93.      */
  94. #ifdef __GNU_LIBRARY__
  95.     static char *getoptSpec = "+qc:f:un";
  96. #else
  97.     static char *getoptSpec = "qc:f:un";
  98. #endif
  99.  
  100.     /*
  101.      * Scan arguments looking for flags to process here rather than to pass
  102.      * on to the scripts.  The '-c' or '-f' must also be the last option to
  103.      * allow for script arguments starting with `-'.
  104.      */
  105.     while ((option = getopt (argc, argv, getoptSpec)) != -1) {
  106.         switch (option) {
  107.           case 'q':
  108.             if (quick)
  109.                 goto usageError;
  110.             quick = TRUE;
  111.             break;
  112.           case 'n':
  113.             if (noDump)
  114.                 goto usageError;
  115.             noDump = TRUE;
  116.             break;
  117.           case 'c':
  118.             evalCmd = optarg;
  119.             goto exitParse;
  120.           case 'f':
  121.             evalFile = optarg;
  122.             goto exitParse;
  123.           case 'u':
  124.           default:
  125.             goto usageError;
  126.         }
  127.     }
  128.   exitParse:
  129.   
  130.     /*
  131.      * If neither `-c' nor `-f' were specified and at least one parameter
  132.      * is supplied, then if is the file to execute.  The rest of the arguments
  133.      * are passed to the script.  Check for '--' as the last option, this also
  134.      * is a terminator for the file to execute.
  135.      */
  136.     if ((evalCmd == NULL) && (evalFile == NULL) && (optind != argc) &&
  137.         !STREQU (argv [optind-1], "--")) {
  138.         evalFile = argv [optind];
  139.         optind++;
  140.     }
  141.  
  142.     /*
  143.      * Set the Tcl argv0, argv & argc variables.
  144.      */
  145.     if (Tcl_SetVar (interp, "argv0",
  146.                     (evalFile != NULL) ? evalFile : argv [0],
  147.                     TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG) == NULL)
  148.         goto tclError;
  149.  
  150.     tclArgv = Tcl_Merge (argc - optind,  &argv [optind]);
  151.     if (Tcl_SetVar (interp, "argv", tclArgv,
  152.                     TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG) == NULL)
  153.         goto tclError;
  154.     ckfree (tclArgv);
  155.  
  156.     sprintf (numBuf, "%d", argc - optind);
  157.     if (Tcl_SetVar (interp, "argc", numBuf, 
  158.                     TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG) == NULL)
  159.         goto tclError;
  160.  
  161.     /*
  162.      * Set the interactive flag, based on what we have parsed.
  163.      */
  164.     if (Tcl_SetVar (interp, "tcl_interactive", 
  165.                     ((evalCmd == NULL) && (evalFile == NULL)) ? "1" : "0",
  166.                     TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG) == NULL)
  167.         goto tclError;
  168.  
  169.     /*
  170.      * Set elements in the TCLXENV array.
  171.      */
  172.     if (evalCmd != NULL) {
  173.         if (Tcl_SetVar2 (interp, TCLXENV, "evalCmd", evalCmd,
  174.                          TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG) == NULL)
  175.             goto tclError;
  176.     }
  177.     if (evalFile != NULL) {
  178.         if (Tcl_SetVar2 (interp, TCLXENV, "evalFile", evalFile,
  179.                          TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG) == NULL)
  180.             goto tclError;
  181.     }
  182.     if (quick) {
  183.         if (Tcl_SetVar2 (interp, TCLXENV, "quick", "1",
  184.                          TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG) == NULL)
  185.             goto tclError;
  186.     }
  187.     if (noDump) {
  188.         if (Tcl_SetVar2 (interp, TCLXENV, "noDump", "1",
  189.                          TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG) == NULL)
  190.             goto tclError;
  191.     }
  192.     return;
  193.  
  194.   usageError:
  195.     fprintf (stderr, "usage: %s %s\n", argv [0],
  196.              "?-qun? ?-f? ?script?|?-c command? ?args?");
  197.     exit (1);
  198.  
  199.   tclError:
  200.     TclX_ErrorExit (interp, 255);
  201. }
  202.  
  203.  
  204. /*
  205.  *-----------------------------------------------------------------------------
  206.  *
  207.  * TclX_Shell --
  208.  *
  209.  *   This function runs the TclX shell, including parsing the command line and
  210.  * calling the Tcl_AppInit function at the approriate place.  It either enters
  211.  * interactive command mode or evaulates a script or command from the command
  212.  * line.
  213.  *
  214.  * Parameters:
  215.  *   o argc, argv - Arguments passed to main for the command line.
  216.  * Notes:
  217.  *   Does not return.
  218.  *-----------------------------------------------------------------------------
  219.  */
  220. void
  221. TclX_Shell (argc, argv)
  222.     int    argc;
  223.     char **argv;
  224. {
  225.     Tcl_Interp *interp;
  226.     char       *evalStr;
  227.  
  228.     /* 
  229.      * Create a basic Tcl interpreter.
  230.      */
  231.     interp = Tcl_CreateInterp();
  232.  
  233.     /*
  234.      * Do command line parsing.  This does not return on an error.  Information
  235.      * for command line is saved in Tcl variables.
  236.      */
  237.     ParseCmdLine (interp, argc, argv);
  238.  
  239.     /*
  240.      * Initialized all packages and application specific commands.  This
  241.      * includes Extended Tcl initialization.
  242.      */
  243.     if (Tcl_AppInit (interp) == TCL_ERROR)
  244.         goto errorExit;
  245.  
  246.     /*
  247.      * Evaluate either a command or file if it was specified on the command
  248.      * line.
  249.      */
  250.     evalStr = Tcl_GetVar2 (interp, TCLXENV, "evalCmd", TCL_GLOBAL_ONLY);
  251.     if (evalStr != NULL) {
  252.         if (Tcl_Eval (interp, evalStr) == TCL_ERROR)
  253.             goto errorExit;
  254.         goto okExit;
  255.     }
  256.  
  257.     evalStr = Tcl_GetVar2 (interp, TCLXENV, "evalFile", TCL_GLOBAL_ONLY);
  258.     if (evalStr != NULL) {
  259.         if (Tcl_EvalFile (interp, evalStr) == TCL_ERROR)
  260.             goto errorExit;
  261.         goto okExit;
  262.     }
  263.     
  264.     /*
  265.      * Otherwise, enter an interactive command loop.  Setup SIGINT handling
  266.      * so user may interrupt with out killing program.
  267.      */
  268.     TclX_EvalRCFile (interp);
  269.     Tcl_SetupSigInt ();
  270.  
  271.     if (Tcl_CommandLoop (interp, isatty (0)) == TCL_ERROR)
  272.         goto errorExit;
  273.  
  274.   okExit:
  275.     /* 
  276.      * Delete the interpreter if memory debugging or explictly requested.
  277.      * Useful for finding memory leaks.
  278.      */
  279.  
  280. #if defined(TCL_MEM_DEBUG)
  281.     Tcl_DeleteInterp (interp);
  282.     fprintf (stderr, " >>> Dumping active memory list to mem.lst <<<\n");
  283.     if (Tcl_DumpActiveMemory ("mem.lst") != TCL_OK)
  284.         panic ("error accessing `mem.lst': %s", strerror (errno));
  285.     exit (0);
  286. #endif
  287.  
  288.     /*
  289.      * Exit though the exit command to clean up, unless the interpreter is
  290.      * to be deleted.
  291.      */
  292.     if (!tclDeleteInterpAtEnd) {
  293.         Tcl_GlobalEval (interp, exitCmd);
  294.     } else {
  295.         Tcl_DeleteInterp (interp);
  296.     }
  297.     exit (0);
  298.  
  299.   errorExit:
  300.     TclX_ErrorExit (interp, 255);
  301. }
  302.