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 / tclXinit.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-01-11  |  6.5 KB  |  226 lines
  1. /*
  2.  * tclXinit.c --
  3.  *
  4.  * Extended Tcl initialzation and initialization utilitied.
  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: tclXinit.c,v 3.1 1993/12/03 10:25:23 markd Exp $
  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.  
  69.     fflush (stdout);
  70.     fprintf (stderr, "Error: %s\n", interp->result);
  71.  
  72.     if (Tcl_GetVar2 (interp, "TCLXENV", "noDump", TCL_GLOBAL_ONLY) == NULL) {
  73.         errorStack = Tcl_GetVar (interp, "errorInfo", TCL_GLOBAL_ONLY);
  74.         if (errorStack != NULL)
  75.             fprintf (stderr, "%s\n", errorStack);
  76.     }
  77.  
  78.     /*
  79.      * Use "exit" command to exit.
  80.      */
  81.     sprintf (numBuf, "%d", exitCode);
  82.     Tcl_VarEval (interp, "exit ", numBuf, (char *) NULL);
  83.     
  84.     /*
  85.      * If that failed, really exit.
  86.      */
  87.     exit (exitCode);
  88. }
  89.  
  90. /*
  91.  *-----------------------------------------------------------------------------
  92.  * ProcessInitFile --
  93.  *
  94.  *   Evaluate the specified init file.
  95.  *
  96.  * Parameters:
  97.  *   o interp  (I) - A pointer to the interpreter.
  98.  *   o initFile (I) - The path to the init file.
  99.  *   o overrideEnv (I) - Directory override environment variable for error msg.
  100.  * Returns:
  101.  *   TCL_OK if all is ok, TCL_ERROR if an error occured.
  102.  *-----------------------------------------------------------------------------
  103.  */
  104. static int
  105. ProcessInitFile (interp, initFile, overrideEnv)
  106.     Tcl_Interp *interp;
  107.     char       *initFile;
  108.     char       *overrideEnv;
  109. {
  110.     struct stat  statBuf;
  111.  
  112.     /*
  113.      * Check for file before evaling it so we can return a helpful error.
  114.      */
  115.     if (stat (initFile, &statBuf) < 0) {
  116.         Tcl_AppendResult (interp,
  117.                           "Can't access initialization file \"",
  118.                           initFile, "\".\n", 
  119.                           "  Override directory containing this file with ",
  120.                           "the environment variable: \"",
  121.                           overrideEnv, "\"", (char *) NULL);
  122.         return TCL_ERROR;
  123.     }
  124.  
  125.     if (Tcl_EvalFile (interp, initFile) != TCL_OK)
  126.         return TCL_ERROR;
  127.         
  128.     Tcl_ResetResult (interp);
  129.     return TCL_OK;
  130. }
  131.  
  132. /*
  133.  *-----------------------------------------------------------------------------
  134.  *
  135.  * TclX_Init --
  136.  *
  137.  *   Initialize all Extended Tcl commands, set auto_path and source the
  138.  * Tcl init file.
  139.  *-----------------------------------------------------------------------------
  140.  */
  141. int
  142. TclX_Init (interp)
  143.     Tcl_Interp *interp;
  144. {
  145.     char        *value;
  146.     Tcl_DString  libDir;
  147.  
  148.     if (TclXCmd_Init (interp) == TCL_ERROR)
  149.         return TCL_ERROR;
  150.  
  151.     if (TclXLib_Init (interp) == TCL_ERROR)
  152.         return TCL_ERROR;
  153.  
  154.     Tcl_DStringInit (&libDir);
  155.  
  156.     /*
  157.      * Get the path to the master (library) directory.
  158.      */
  159.     value = Tcl_GetVar2 (interp, "env", tclLibraryEnv, TCL_GLOBAL_ONLY);
  160.     if (value != NULL)
  161.         Tcl_DStringAppend (&libDir, value, -1);
  162.     else
  163.         Tcl_DStringAppend (&libDir, TCL_MASTERDIR, -1);
  164.  
  165.     /*
  166.      * Set auto_path.
  167.      */
  168.     if (Tcl_SetVar (interp, "auto_path", libDir.string,
  169.                     TCL_GLOBAL_ONLY  | TCL_APPEND_VALUE |
  170.                     TCL_LIST_ELEMENT | TCL_LEAVE_ERR_MSG) == NULL)
  171.         goto errorExit;
  172.  
  173.     /*
  174.      * Evaluate the init file unless the quick flag is set.
  175.      */
  176.     if (Tcl_GetVar2 (interp, "TCLXENV", "quick", TCL_GLOBAL_ONLY) == NULL) {
  177.         Tcl_DStringAppend (&libDir, "/", -1);
  178.         Tcl_DStringAppend (&libDir, "TclInit.tcl", -1);
  179.  
  180.         if (ProcessInitFile (interp, libDir.string,
  181.                              tclLibraryEnv) == TCL_ERROR)
  182.             goto errorExit;
  183.     }
  184.  
  185.     Tcl_DStringFree (&libDir);
  186.     return TCL_OK;
  187.  
  188.   errorExit:
  189.     Tcl_DStringFree (&libDir);
  190.     return TCL_ERROR;
  191. }
  192.  
  193. /*
  194.  *-----------------------------------------------------------------------------
  195.  *
  196.  * TclX_EvalRCFile --
  197.  *
  198.  * Evaluate the file stored in tcl_RcFileName it is readable.  Exit if an
  199.  * error occurs.
  200.  *
  201.  * Parameters:
  202.  *   o interp (I) - A pointer to the interpreter.
  203.  *-----------------------------------------------------------------------------
  204.  */
  205. void
  206. TclX_EvalRCFile (interp)
  207.     Tcl_Interp  *interp;
  208. {
  209.     Tcl_DString  buffer;
  210.     char        *fullName;
  211.     int          code;
  212.  
  213.     if (tcl_RcFileName != NULL) {
  214.         fullName = Tcl_TildeSubst (interp, tcl_RcFileName, &buffer);
  215.         if (fullName == NULL)
  216.             TclX_ErrorExit (interp, 1);
  217.         
  218.         if (access(fullName, R_OK) == 0) {
  219.             code = Tcl_EvalFile (interp, fullName);
  220.             if (code == TCL_ERROR)
  221.                 TclX_ErrorExit (interp, 1);
  222.         }
  223.     Tcl_DStringFree(&buffer);
  224.     }
  225. }
  226.