summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2004-06-11 21:30:05 (GMT)
committerdgp <dgp@users.sourceforge.net>2004-06-11 21:30:05 (GMT)
commit3f216823de7161e66adb2ff6c4f199f604110dd9 (patch)
treebc418bb1e1a10d6b91c844443c129679ccfbbbd1 /generic
parent4ddc6442ba71c437f4b4bfb3c8ecff5b908b0957 (diff)
downloadtcl-3f216823de7161e66adb2ff6c4f199f604110dd9.zip
tcl-3f216823de7161e66adb2ff6c4f199f604110dd9.tar.gz
tcl-3f216823de7161e66adb2ff6c4f199f604110dd9.tar.bz2
* unix/tclUnixInit.c: The routines Tcl_Init() and TclSourceRCFile()
* win/tclWinInit.c: had identical implementations for both win and * generic/tclInterp.c: unix. Moved to a single generic implementation. * generic/tclMain.c: * library/init.tcl: * generic/tclInitScript.h (removed): * unix/Makefile.in: * win/tcl.dsp:
Diffstat (limited to 'generic')
-rw-r--r--generic/tclInitScript.h111
-rw-r--r--generic/tclInterp.c140
-rw-r--r--generic/tclMain.c62
3 files changed, 198 insertions, 115 deletions
diff --git a/generic/tclInitScript.h b/generic/tclInitScript.h
deleted file mode 100644
index 18b8cb7..0000000
--- a/generic/tclInitScript.h
+++ /dev/null
@@ -1,111 +0,0 @@
-/*
- * tclInitScript.h --
- *
- * This file contains Unix & Windows common init script
- *
- * Copyright (c) 1998 Sun Microsystems, Inc.
- * Copyright (c) 1999 by Scriptics Corporation.
- * All rights reserved.
- *
- * RCS: @(#) $Id: tclInitScript.h,v 1.15 2004/03/17 18:14:13 das Exp $
- */
-
-/*
- * In order to find init.tcl during initialization, the following script
- * is invoked by Tcl_Init(). It looks in several different directories:
- *
- * $tcl_library - can specify a primary location, if set
- * no other locations will be checked
- *
- * $env(TCL_LIBRARY) - highest priority so user can always override
- * the search path unless the application has
- * specified an exact directory above
- *
- * $tclDefaultLibrary - this value is initialized by TclPlatformInit
- * from a static C variable that was set at
- * compile time
- *
- * $tcl_libPath - this value is initialized by a call to
- * TclGetLibraryPath called from Tcl_Init.
- *
- * The first directory on this path that contains a valid init.tcl script
- * will be set as the value of tcl_library.
- *
- * Note that this entire search mechanism can be bypassed by defining an
- * alternate tclInit procedure before calling Tcl_Init().
- */
-
-static char initScript[] = "if {[info proc tclInit]==\"\"} {\n\
- proc tclInit {} {\n\
- global tcl_libPath tcl_library errorInfo\n\
- global env tclDefaultLibrary\n\
- rename tclInit {}\n\
- set errors {}\n\
- set dirs {}\n\
- if {[info exists tcl_library]} {\n\
- lappend dirs $tcl_library\n\
- } else {\n\
- if {[info exists env(TCL_LIBRARY)]} {\n\
- lappend dirs $env(TCL_LIBRARY)\n\
- }\n\
- catch {\n\
- lappend dirs $tclDefaultLibrary\n\
- unset tclDefaultLibrary\n\
- }\n\
- set dirs [concat $dirs $tcl_libPath]\n\
- }\n\
- foreach i $dirs {\n\
- set tcl_library $i\n\
- set tclfile [file join $i init.tcl]\n\
- if {[file exists $tclfile]} {\n\
- if {![catch {uplevel #0 [list source $tclfile]} msg]} {\n\
- return\n\
- } else {\n\
- append errors \"$tclfile: $msg\n$errorInfo\n\"\n\
- }\n\
- }\n\
- }\n\
- set msg \"Can't find a usable init.tcl in the following directories: \n\"\n\
- append msg \" $dirs\n\n\"\n\
- append msg \"$errors\n\n\"\n\
- append msg \"This probably means that Tcl wasn't installed properly.\n\"\n\
- error $msg\n\
- }\n\
-}\n\
-tclInit";
-
-
-/*
- * A pointer to a string that holds an initialization script that if non-NULL
- * is evaluated in Tcl_Init() prior to the built-in initialization script
- * above. This variable can be modified by the procedure below.
- */
-
-static char * tclPreInitScript = NULL;
-
-
-/*
- *----------------------------------------------------------------------
- *
- * TclSetPreInitScript --
- *
- * This routine is used to change the value of the internal
- * variable, tclPreInitScript.
- *
- * Results:
- * Returns the current value of tclPreInitScript.
- *
- * Side effects:
- * Changes the way Tcl_Init() routine behaves.
- *
- *----------------------------------------------------------------------
- */
-
-char *
-TclSetPreInitScript (string)
- char *string; /* Pointer to a script. */
-{
- char *prevString = tclPreInitScript;
- tclPreInitScript = string;
- return(prevString);
-}
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index fff810a..54f0cbc 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -10,11 +10,149 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInterp.c,v 1.35 2004/05/30 12:18:26 dkf Exp $
+ * RCS: @(#) $Id: tclInterp.c,v 1.36 2004/06/11 21:30:07 dgp Exp $
*/
#include "tclInt.h"
#include <stdio.h>
+
+/*
+ * In order to find init.tcl during initialization, the following script
+ * is invoked by Tcl_Init(). It looks in several different directories:
+ *
+ * $tcl_library - can specify a primary location, if set
+ * no other locations will be checked
+ *
+ * $env(TCL_LIBRARY) - highest priority so user can always override
+ * the search path unless the application has
+ * specified an exact directory above
+ *
+ * $tclDefaultLibrary - this value is initialized by TclPlatformInit
+ * from a static C variable that was set at
+ * compile time
+ *
+ * $tcl_libPath - this value is initialized by a call to
+ * TclGetLibraryPath called from Tcl_Init.
+ *
+ * The first directory on this path that contains a valid init.tcl script
+ * will be set as the value of tcl_library.
+ *
+ * Note that this entire search mechanism can be bypassed by defining an
+ * alternate tclInit procedure before calling Tcl_Init().
+ */
+
+static char initScript[] = "if {[info proc tclInit]==\"\"} {\n\
+ proc tclInit {} {\n\
+ global tcl_libPath tcl_library errorInfo\n\
+ global env tclDefaultLibrary\n\
+ rename tclInit {}\n\
+ set errors {}\n\
+ set dirs {}\n\
+ if {[info exists tcl_library]} {\n\
+ lappend dirs $tcl_library\n\
+ } else {\n\
+ if {[info exists env(TCL_LIBRARY)]} {\n\
+ lappend dirs $env(TCL_LIBRARY)\n\
+ }\n\
+ catch {\n\
+ lappend dirs $tclDefaultLibrary\n\
+ unset tclDefaultLibrary\n\
+ }\n\
+ set dirs [concat $dirs $tcl_libPath]\n\
+ }\n\
+ foreach i $dirs {\n\
+ set tcl_library $i\n\
+ set tclfile [file join $i init.tcl]\n\
+ if {[file exists $tclfile]} {\n\
+ if {![catch {uplevel #0 [list source $tclfile]} msg]} {\n\
+ return\n\
+ } else {\n\
+ append errors \"$tclfile: $msg\n$errorInfo\n\"\n\
+ }\n\
+ }\n\
+ }\n\
+ set msg \"Can't find a usable init.tcl in the following directories: \n\"\n\
+ append msg \" $dirs\n\n\"\n\
+ append msg \"$errors\n\n\"\n\
+ append msg \"This probably means that Tcl wasn't installed properly.\n\"\n\
+ error $msg\n\
+ }\n\
+}\n\
+tclInit";
+
+/*
+ * A pointer to a string that holds an initialization script that if non-NULL
+ * is evaluated in Tcl_Init() prior to the built-in initialization script
+ * above. This variable can be modified by the procedure below.
+ */
+
+static char * tclPreInitScript = NULL;
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclSetPreInitScript --
+ *
+ * This routine is used to change the value of the internal
+ * variable, tclPreInitScript.
+ *
+ * Results:
+ * Returns the current value of tclPreInitScript.
+ *
+ * Side effects:
+ * Changes the way Tcl_Init() routine behaves.
+ *
+ *----------------------------------------------------------------------
+ */
+
+char *
+TclSetPreInitScript (string)
+ char *string; /* Pointer to a script. */
+{
+ char *prevString = tclPreInitScript;
+ tclPreInitScript = string;
+ return(prevString);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_Init --
+ *
+ * This procedure is typically invoked by Tcl_AppInit procedures
+ * to find and source the "init.tcl" script, which should exist
+ * somewhere on the Tcl library path.
+ *
+ * Results:
+ * Returns a standard Tcl completion code and sets the interp's
+ * result if there is an error.
+ *
+ * Side effects:
+ * Depends on what's in the init.tcl script.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_Init(interp)
+ Tcl_Interp *interp; /* Interpreter to initialize. */
+{
+ Tcl_Obj *pathPtr;
+
+ if (tclPreInitScript != NULL) {
+ if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) {
+ return (TCL_ERROR);
+ };
+ }
+
+ pathPtr = TclGetLibraryPath();
+ if (pathPtr == NULL) {
+ pathPtr = Tcl_NewObj();
+ }
+ Tcl_SetVar2Ex(interp, "tcl_libPath", NULL, pathPtr, TCL_GLOBAL_ONLY);
+ return Tcl_Eval(interp, initScript);
+}
/*
* Counter for how many aliases were created (global)
diff --git a/generic/tclMain.c b/generic/tclMain.c
index f1ca13f..1e736fe 100644
--- a/generic/tclMain.c
+++ b/generic/tclMain.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclMain.c,v 1.26 2004/05/13 12:59:23 dkf Exp $
+ * RCS: @(#) $Id: tclMain.c,v 1.27 2004/06/11 21:30:08 dgp Exp $
*/
#include "tclInt.h"
@@ -237,10 +237,66 @@ CONST char *TclGetStartupScriptFileName()
}
return Tcl_GetString(path);
}
-
-/*
+/*----------------------------------------------------------------------
+ *
+ * Tcl_SourceRCFile --
+ *
+ * This procedure is typically invoked by Tcl_Main of Tk_Main
+ * procedure to source an application specific rc file into the
+ * interpreter at startup time.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Depends on what's in the rc script.
+ *
*----------------------------------------------------------------------
+ */
+
+void
+Tcl_SourceRCFile(interp)
+ Tcl_Interp *interp; /* Interpreter to source rc file into. */
+{
+ Tcl_DString temp;
+ CONST char *fileName;
+ Tcl_Channel errChannel;
+
+ fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY);
+ if (fileName != NULL) {
+ Tcl_Channel c;
+ CONST char *fullName;
+
+ Tcl_DStringInit(&temp);
+ fullName = Tcl_TranslateFileName(interp, fileName, &temp);
+ if (fullName == NULL) {
+ /*
+ * Couldn't translate the file name (e.g. it referred to a
+ * bogus user or there was no HOME environment variable).
+ * Just do nothing.
+ */
+ } else {
+ /*
+ * Test for the existence of the rc file before trying to read it.
+ */
+ c = Tcl_OpenFileChannel(NULL, fullName, "r", 0);
+ if (c != (Tcl_Channel) NULL) {
+ Tcl_Close(NULL, c);
+ if (Tcl_EvalFile(interp, fullName) != TCL_OK) {
+ errChannel = Tcl_GetStdChannel(TCL_STDERR);
+ if (errChannel) {
+ Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
+ Tcl_WriteChars(errChannel, "\n", 1);
+ }
+ }
+ }
+ }
+ Tcl_DStringFree(&temp);
+ }
+}
+
+/*----------------------------------------------------------------------
*
* Tcl_Main --
*