home *** CD-ROM | disk | FTP | other *** search
/ Serving the Web / ServingTheWeb1995.disc1of1.iso / linux / slacksrce / tcl / tcl+tk+t / tclx7.3bl / tclx7 / tclX7.3b / src / tclXinit.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-07-16  |  6.6 KB  |  230 lines
  1. /*
  2.  * tclXinit.c --
  3.  *
  4.  * Extended Tcl initialzation and initialization utilitied.
  5.  *-----------------------------------------------------------------------------
  6.  * Copyright 1991-1994 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: tclXinit.c,v 4.0 1994/07/16 05:28:21 markd Rel $
  16.  *-----------------------------------------------------------------------------
  17.  */
  18.  
  19. #include "tclExtdInt.h"
  20.  
  21. /*
  22.  * If this variable is non-zero, the TclX shell will delete the interpreter
  23.  * at the end of a script instead of evaluating the "exit" command.  This is
  24.  * for applications that want to track down memory leaks.
  25.  */
  26. int tclDeleteInterpAtEnd = FALSE;
  27.  
  28.  
  29. /*
  30.  * The following is used to force the version of tclCmdIL.c that was compiled
  31.  * for TclX to be brought in rather than the standard version.
  32.  */
  33. int *tclxDummyInfoCmdPtr = (int *) Tcl_InfoCmd;
  34.  
  35. static char *tclLibraryEnv = "TCL_LIBRARY";
  36.  
  37. /*
  38.  * Prototypes of internal functions.
  39.  */
  40. static int
  41. ProcessInitFile _ANSI_ARGS_((Tcl_Interp *interp,
  42.                              char       *initFile,
  43.                              char       *overrideEnv));
  44.  
  45.  
  46. /*
  47.  *-----------------------------------------------------------------------------
  48.  *
  49.  * TclX_ErrorExit --
  50.  *
  51.  * Display error information and abort when an error is returned in the
  52.  * interp->result. It uses TCLXENV(noDump) to determine if the stack should be
  53.  * dumped.  Attempts to use the "exit" command to exit, so cleanup can be done.
  54.  *
  55.  * Parameters:
  56.  *   o interp - A pointer to the interpreter, should contain the
  57.  *     error message in `result'.
  58.  *   o exitCode - The code to pass to exit.
  59.  *-----------------------------------------------------------------------------
  60.  */
  61. void
  62. TclX_ErrorExit (interp, exitCode)
  63.     Tcl_Interp  *interp;
  64.     int          exitCode;
  65. {
  66.     char *errorStack;
  67.     char  numBuf [32];
  68.     FILE *stdoutPtr, *stderrPtr;
  69.  
  70.     stdoutPtr = TCL_STDOUT;
  71.     stderrPtr = TCL_STDERR;
  72.  
  73.     fflush (stdoutPtr);
  74.     fprintf (stderrPtr, "Error: %s\n", interp->result);
  75.  
  76.     if (Tcl_GetVar2 (interp, "TCLXENV", "noDump", TCL_GLOBAL_ONLY) == NULL) {
  77.         errorStack = Tcl_GetVar (interp, "errorInfo", TCL_GLOBAL_ONLY);
  78.         if (errorStack != NULL)
  79.             fprintf (stderrPtr, "%s\n", errorStack);
  80.     }
  81.  
  82.     /*
  83.      * Use "exit" command to exit.
  84.      */
  85.     sprintf (numBuf, "%d", exitCode);
  86.     Tcl_VarEval (interp, "exit ", numBuf, (char *) NULL);
  87.     
  88.     /*
  89.      * If that failed, really exit.
  90.      */
  91.     exit (exitCode);
  92. }
  93.  
  94. /*
  95.  *-----------------------------------------------------------------------------
  96.  * ProcessInitFile --
  97.  *
  98.  *   Evaluate the specified init file.
  99.  *
  100.  * Parameters:
  101.  *   o interp  (I) - A pointer to the interpreter.
  102.  *   o initFile (I) - The path to the init file.
  103.  *   o overrideEnv (I) - Directory override environment variable for error msg.
  104.  * Returns:
  105.  *   TCL_OK if all is ok, TCL_ERROR if an error occured.
  106.  *-----------------------------------------------------------------------------
  107.  */
  108. static int
  109. ProcessInitFile (interp, initFile, overrideEnv)
  110.     Tcl_Interp *interp;
  111.     char       *initFile;
  112.     char       *overrideEnv;
  113. {
  114.     struct stat  statBuf;
  115.  
  116.     /*
  117.      * Check for file before evaling it so we can return a helpful error.
  118.      */
  119.     if (stat (initFile, &statBuf) < 0) {
  120.         Tcl_AppendResult (interp,
  121.                           "Can't access initialization file \"",
  122.                           initFile, "\".\n", 
  123.                           "  Override directory containing this file with ",
  124.                           "the environment variable: \"",
  125.                           overrideEnv, "\"", (char *) NULL);
  126.         return TCL_ERROR;
  127.     }
  128.  
  129.     if (Tcl_EvalFile (interp, initFile) != TCL_OK)
  130.         return TCL_ERROR;
  131.         
  132.     Tcl_ResetResult (interp);
  133.     return TCL_OK;
  134. }
  135.  
  136. /*
  137.  *-----------------------------------------------------------------------------
  138.  *
  139.  * TclX_Init --
  140.  *
  141.  *   Initialize all Extended Tcl commands, set auto_path and source the
  142.  * Tcl init file.
  143.  *-----------------------------------------------------------------------------
  144.  */
  145. int
  146. TclX_Init (interp)
  147.     Tcl_Interp *interp;
  148. {
  149.     char        *value;
  150.     Tcl_DString  libDir;
  151.  
  152.     if (TclXCmd_Init (interp) == TCL_ERROR)
  153.         return TCL_ERROR;
  154.  
  155.     if (TclXLib_Init (interp) == TCL_ERROR)
  156.         return TCL_ERROR;
  157.  
  158.     Tcl_DStringInit (&libDir);
  159.  
  160.     /*
  161.      * Get the path to the master (library) directory.
  162.      */
  163.     value = Tcl_GetVar2 (interp, "env", tclLibraryEnv, TCL_GLOBAL_ONLY);
  164.     if (value != NULL)
  165.         Tcl_DStringAppend (&libDir, value, -1);
  166.     else
  167.         Tcl_DStringAppend (&libDir, TCL_MASTERDIR, -1);
  168.  
  169.     /*
  170.      * Set auto_path.
  171.      */
  172.     if (Tcl_SetVar (interp, "auto_path", libDir.string,
  173.                     TCL_GLOBAL_ONLY  | TCL_APPEND_VALUE |
  174.                     TCL_LIST_ELEMENT | TCL_LEAVE_ERR_MSG) == NULL)
  175.         goto errorExit;
  176.  
  177.     /*
  178.      * Evaluate the init file unless the quick flag is set.
  179.      */
  180.     if (Tcl_GetVar2 (interp, "TCLXENV", "quick", TCL_GLOBAL_ONLY) == NULL) {
  181.         Tcl_DStringAppend (&libDir, "/", -1);
  182.         Tcl_DStringAppend (&libDir, "TclInit.tcl", -1);
  183.  
  184.         if (ProcessInitFile (interp, libDir.string,
  185.                              tclLibraryEnv) == TCL_ERROR)
  186.             goto errorExit;
  187.     }
  188.  
  189.     Tcl_DStringFree (&libDir);
  190.     return TCL_OK;
  191.  
  192.   errorExit:
  193.     Tcl_DStringFree (&libDir);
  194.     return TCL_ERROR;
  195. }
  196.  
  197. /*
  198.  *-----------------------------------------------------------------------------
  199.  *
  200.  * TclX_EvalRCFile --
  201.  *
  202.  * Evaluate the file stored in tcl_RcFileName it is readable.  Exit if an
  203.  * error occurs.
  204.  *
  205.  * Parameters:
  206.  *   o interp (I) - A pointer to the interpreter.
  207.  *-----------------------------------------------------------------------------
  208.  */
  209. void
  210. TclX_EvalRCFile (interp)
  211.     Tcl_Interp  *interp;
  212. {
  213.     Tcl_DString  buffer;
  214.     char        *fullName;
  215.     int          code;
  216.  
  217.     if (tcl_RcFileName != NULL) {
  218.         fullName = Tcl_TildeSubst (interp, tcl_RcFileName, &buffer);
  219.         if (fullName == NULL)
  220.             TclX_ErrorExit (interp, 1);
  221.         
  222.         if (access(fullName, R_OK) == 0) {
  223.             code = Tcl_EvalFile (interp, fullName);
  224.             if (code == TCL_ERROR)
  225.                 TclX_ErrorExit (interp, 1);
  226.         }
  227.     Tcl_DStringFree(&buffer);
  228.     }
  229. }
  230.