diff options
| -rw-r--r-- | ChangeLog | 16 | ||||
| -rw-r--r-- | generic/tclEncoding.c | 84 | ||||
| -rw-r--r-- | generic/tclEvent.c | 83 | ||||
| -rw-r--r-- | generic/tclInt.decls | 8 | ||||
| -rw-r--r-- | generic/tclIntDecls.h | 17 | ||||
| -rw-r--r-- | generic/tclMain.c | 80 | ||||
| -rw-r--r-- | generic/tclStubInit.c | 4 | ||||
| -rw-r--r-- | unix/tclAppInit.c | 31 | ||||
| -rw-r--r-- | win/tclAppInit.c | 46 |
9 files changed, 266 insertions, 103 deletions
@@ -1,3 +1,19 @@ +1999-12-01 Scott Redman <redman@scriptics.com> + + * generic/tcl.decls : + * generic/tclMain.c : + * unix/tclAppInit.c: + * win/tclAppInit.c: Added two new internal functions, + TclSetStartupScriptFileName() and TclGetStartupScriptFileName() + and added hooks into the main() code for supporting TclPro and + other "big" shells more easily without requiring a copy of the + main() code. + + * generic/tclEncoding.c: + * generic/tclEvent.c: Moved encoding-related startup code from + tclEvent.c into the more appropriate tclEncoding.c. + + 1999-11-30 Jeff Hobbs <hobbs@scriptics.com> * generic/tclIO.c: fix from Kupries for Tcl_UnstackChannel that diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 40ded74..ad86495 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclEncoding.c,v 1.2 1999/04/16 00:46:45 stanton Exp $ + * RCS: @(#) $Id: tclEncoding.c,v 1.3 1999/12/02 02:03:22 redman Exp $ */ #include "tclInt.h" @@ -143,6 +143,8 @@ typedef struct EscapeEncodingData { char *tclDefaultEncodingDir = NULL; +static int encodingsInitialized = 0; + /* * Hash table that keeps track of all loaded Encodings. Keys are * the string names that represent the encoding, values are (Encoding *). @@ -311,6 +313,7 @@ TclFinalizeEncodingSubsystem() Encoding *encodingPtr; Tcl_MutexLock(&encodingMutex); + encodingsInitialized = 0; hPtr = Tcl_FirstHashEntry(&encodingTable, &search); while (hPtr != NULL) { encodingPtr = (Encoding *) Tcl_GetHashValue(hPtr); @@ -2682,4 +2685,83 @@ unilen(src) return (char *) p - src; } + +/* + *------------------------------------------------------------------------- + * + * TclFindEncodings -- + * + * Find and load the encoding file for this operating system. + * Before this is called, Tcl makes assumptions about the + * native string representation, but the true encoding is not + * assured. + * + * Results: + * None. + * + * Side effects: + * Varied, see the respective initialization routines. + * + *------------------------------------------------------------------------- + */ + +void +TclFindEncodings(argv0) + CONST char *argv0; /* Name of executable from argv[0] to main() + * in native multi-byte encoding. */ +{ + char *native; + Tcl_Obj *pathPtr; + Tcl_DString libPath, buffer; + + if (encodingsInitialized == 0) { + /* + * Double check inside the mutex. There may be calls + * back into this routine from some of the procedures below. + */ + + TclpInitLock(); + if (encodingsInitialized == 0) { + /* + * Have to set this bit here to avoid deadlock with the + * routines below us that call into TclInitSubsystems. + */ + + encodingsInitialized = 1; + + native = TclpFindExecutable(argv0); + TclpInitLibraryPath(native); + + /* + * The library path was set in the TclpInitLibraryPath routine. + * The string set is a dirty UTF string. To preserve the value + * convert the UTF string back to native before setting the new + * default encoding. + */ + + pathPtr = TclGetLibraryPath(); + if (pathPtr != NULL) { + Tcl_UtfToExternalDString(NULL, Tcl_GetString(pathPtr), -1, + &libPath); + } + + TclpSetInitialEncodings(); + + /* + * Now convert the native string back to UTF. + */ + + if (pathPtr != NULL) { + Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&libPath), -1, + &buffer); + pathPtr = Tcl_NewStringObj(Tcl_DStringValue(&buffer), -1); + TclSetLibraryPath(pathPtr); + + Tcl_DStringFree(&libPath); + Tcl_DStringFree(&buffer); + } + } + TclpInitUnlock(); + } +} diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 95f0abb..d81e3e6 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclEvent.c,v 1.6 1999/11/19 06:34:23 hobbs Exp $ + * RCS: @(#) $Id: tclEvent.c,v 1.7 1999/12/02 02:03:23 redman Exp $ */ #include "tclInt.h" @@ -87,7 +87,6 @@ TCL_DECLARE_MUTEX(exitMutex) static int inFinalize = 0; static int subsystemsInitialized = 0; -static int encodingsInitialized = 0; static Tcl_Obj *tclLibraryPath = NULL; @@ -719,85 +718,6 @@ TclInitSubsystems(argv0) } /* - *------------------------------------------------------------------------- - * - * TclFindEncodings -- - * - * Find and load the encoding file for this operating system. - * Before this is called, Tcl makes assumptions about the - * native string representation, but the true encoding is not - * assured. - * - * Results: - * None. - * - * Side effects: - * Varied, see the respective initialization routines. - * - *------------------------------------------------------------------------- - */ - -void -TclFindEncodings(argv0) - CONST char *argv0; /* Name of executable from argv[0] to main() - * in native multi-byte encoding. */ -{ - char *native; - Tcl_Obj *pathPtr; - Tcl_DString libPath, buffer; - - if (encodingsInitialized == 0) { - /* - * Double check inside the mutex. There may be calls - * back into this routine from some of the procedures below. - */ - - TclpInitLock(); - if (encodingsInitialized == 0) { - /* - * Have to set this bit here to avoid deadlock with the - * routines below us that call into TclInitSubsystems. - */ - - encodingsInitialized = 1; - - native = TclpFindExecutable(argv0); - TclpInitLibraryPath(native); - - /* - * The library path was set in the TclpInitLibraryPath routine. - * The string set is a dirty UTF string. To preserve the value - * convert the UTF string back to native before setting the new - * default encoding. - */ - - pathPtr = TclGetLibraryPath(); - if (pathPtr != NULL) { - Tcl_UtfToExternalDString(NULL, Tcl_GetString(pathPtr), -1, - &libPath); - } - - TclpSetInitialEncodings(); - - /* - * Now convert the native string back to UTF. - */ - - if (pathPtr != NULL) { - Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&libPath), -1, - &buffer); - pathPtr = Tcl_NewStringObj(Tcl_DStringValue(&buffer), -1); - TclSetLibraryPath(pathPtr); - - Tcl_DStringFree(&libPath); - Tcl_DStringFree(&buffer); - } - } - TclpInitUnlock(); - } -} - -/* *---------------------------------------------------------------------- * * Tcl_Finalize -- @@ -824,7 +744,6 @@ Tcl_Finalize() TclpInitLock(); if (subsystemsInitialized != 0) { subsystemsInitialized = 0; - encodingsInitialized = 0; /* * Invoke exit handlers first. diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 52604a6..f535e71 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -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: tclInt.decls,v 1.17 1999/08/10 02:42:14 welch Exp $ +# RCS: @(#) $Id: tclInt.decls,v 1.18 1999/12/02 02:03:25 redman Exp $ library tcl @@ -592,6 +592,12 @@ declare 156 generic { declare 157 generic { Var * TclVarTraceExists (Tcl_Interp *interp, char *varName) } +declare 158 generic { + void TclSetStartupScriptFileName(char *filename) +} +declare 159 generic { + char *TclGetStartupScriptFileName(void) +} ############################################################################## diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index fea3857..7e96fee 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIntDecls.h,v 1.17 1999/08/10 02:42:14 welch Exp $ + * RCS: @(#) $Id: tclIntDecls.h,v 1.18 1999/12/02 02:03:26 redman Exp $ */ #ifndef _TCLINTDECLS @@ -519,6 +519,11 @@ EXTERN void TclRegError _ANSI_ARGS_((Tcl_Interp * interp, /* 157 */ EXTERN Var * TclVarTraceExists _ANSI_ARGS_((Tcl_Interp * interp, char * varName)); +/* 158 */ +EXTERN void TclSetStartupScriptFileName _ANSI_ARGS_(( + char * filename)); +/* 159 */ +EXTERN char * TclGetStartupScriptFileName _ANSI_ARGS_((void)); typedef struct TclIntStubs { int magic; @@ -714,6 +719,8 @@ typedef struct TclIntStubs { int (*tclTestChannelEventCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int argc, char ** argv)); /* 155 */ void (*tclRegError) _ANSI_ARGS_((Tcl_Interp * interp, char * msg, int status)); /* 156 */ Var * (*tclVarTraceExists) _ANSI_ARGS_((Tcl_Interp * interp, char * varName)); /* 157 */ + void (*tclSetStartupScriptFileName) _ANSI_ARGS_((char * filename)); /* 158 */ + char * (*tclGetStartupScriptFileName) _ANSI_ARGS_((void)); /* 159 */ } TclIntStubs; #ifdef __cplusplus @@ -1355,6 +1362,14 @@ extern TclIntStubs *tclIntStubsPtr; #define TclVarTraceExists \ (tclIntStubsPtr->tclVarTraceExists) /* 157 */ #endif +#ifndef TclSetStartupScriptFileName +#define TclSetStartupScriptFileName \ + (tclIntStubsPtr->tclSetStartupScriptFileName) /* 158 */ +#endif +#ifndef TclGetStartupScriptFileName +#define TclGetStartupScriptFileName \ + (tclIntStubsPtr->tclGetStartupScriptFileName) /* 159 */ +#endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclMain.c b/generic/tclMain.c index 089452d..4c12fc7 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -9,7 +9,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.5 1999/04/16 00:46:50 stanton Exp $ + * RCS: @(#) $Id: tclMain.c,v 1.6 1999/12/02 02:03:27 redman Exp $ */ #include "tcl.h" @@ -40,6 +40,57 @@ int (*tclDummyLinkVarPtr)() = Tcl_LinkVar; extern int isatty _ANSI_ARGS_((int fd)); extern char * strcpy _ANSI_ARGS_((char *dst, CONST char *src)); +static char *tclStartupScriptFileName = NULL; + + + + +/* + *---------------------------------------------------------------------- + * + * TclSetStartupScriptFileName -- + * + * Primes the startup script file name, used to override the + * command line processing. + * + * Results: + * None. + * + * Side effects: + * This procedure initializes the file name of the Tcl script to + * run at startup. + * + *---------------------------------------------------------------------- + */ +void TclSetStartupScriptFileName(fileName) + char *fileName; +{ + tclStartupScriptFileName = fileName; +} + + +/* + *---------------------------------------------------------------------- + * + * TclGetStartupScriptFileName -- + * + * Gets the startup script file name, used to override the + * command line processing. + * + * Results: + * The startup script file name, NULL if none has been set. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +char *TclGetStartupScriptFileName() +{ + return tclStartupScriptFileName; +} + + /* *---------------------------------------------------------------------- @@ -53,7 +104,7 @@ extern char * strcpy _ANSI_ARGS_((char *dst, CONST char *src)); * it's done. * * Side effects: - * This procedure initializes the Tk world and then starts + * This procedure initializes the Tcl world and then starts * interpreting commands; almost anything could happen, depending * on the script being interpreted. * @@ -72,7 +123,7 @@ Tcl_Main(argc, argv, appInitProc) { Tcl_Obj *resultPtr; Tcl_Obj *commandPtr = NULL; - char buffer[1000], *args, *fileName; + char buffer[1000], *args; int code, gotPartial, tty, length; int exitCode = 0; Tcl_Channel inChannel, outChannel, errChannel; @@ -91,11 +142,12 @@ Tcl_Main(argc, argv, appInitProc) * strip it off and use it as the name of a script file to process. */ - fileName = NULL; - if ((argc > 1) && (argv[1][0] != '-')) { - fileName = argv[1]; - argc--; - argv++; + if (tclStartupScriptFileName == NULL) { + if ((argc > 1) && (argv[1][0] != '-')) { + tclStartupScriptFileName = argv[1]; + argc--; + argv++; + } } args = Tcl_Merge(argc-1, argv+1); Tcl_ExternalToUtfDString(NULL, args, -1, &argString); @@ -103,10 +155,11 @@ Tcl_Main(argc, argv, appInitProc) Tcl_DStringFree(&argString); ckfree(args); - if (fileName == NULL) { + if (tclStartupScriptFileName == NULL) { Tcl_ExternalToUtfDString(NULL, argv[0], -1, &argString); } else { - fileName = Tcl_ExternalToUtfDString(NULL, fileName, -1, &argString); + tclStartupScriptFileName = Tcl_ExternalToUtfDString(NULL, + tclStartupScriptFileName, -1, &argString); } TclFormatInt(buffer, argc-1); @@ -119,7 +172,8 @@ Tcl_Main(argc, argv, appInitProc) tty = isatty(0); Tcl_SetVar(interp, "tcl_interactive", - ((fileName == NULL) && tty) ? "1" : "0", TCL_GLOBAL_ONLY); + ((tclStartupScriptFileName == NULL) && tty) ? "1" : "0", + TCL_GLOBAL_ONLY); /* * Invoke application-specific initialization. @@ -140,8 +194,8 @@ Tcl_Main(argc, argv, appInitProc) * and quit. */ - if (fileName != NULL) { - code = Tcl_EvalFile(interp, fileName); + if (tclStartupScriptFileName != NULL) { + code = Tcl_EvalFile(interp, tclStartupScriptFileName); if (code != TCL_OK) { errChannel = Tcl_GetStdChannel(TCL_STDERR); if (errChannel) { diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index ad790d9..23f916b 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclStubInit.c,v 1.28 1999/08/19 02:59:10 hobbs Exp $ + * RCS: @(#) $Id: tclStubInit.c,v 1.29 1999/12/02 02:03:27 redman Exp $ */ #include "tclInt.h" @@ -233,6 +233,8 @@ TclIntStubs tclIntStubs = { TclTestChannelEventCmd, /* 155 */ TclRegError, /* 156 */ TclVarTraceExists, /* 157 */ + TclSetStartupScriptFileName, /* 158 */ + TclGetStartupScriptFileName, /* 159 */ }; TclIntPlatStubs tclIntPlatStubs = { diff --git a/unix/tclAppInit.c b/unix/tclAppInit.c index 45d86eb..c1126ae 100644 --- a/unix/tclAppInit.c +++ b/unix/tclAppInit.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclAppInit.c,v 1.7 1999/10/13 00:32:49 hobbs Exp $ + * RCS: @(#) $Id: tclAppInit.c,v 1.8 1999/12/02 02:03:32 redman Exp $ */ #include "tcl.h" @@ -66,6 +66,28 @@ main(argc, argv) int argc; /* Number of command-line arguments. */ char **argv; /* Values of command-line arguments. */ { + /* + * The following #if block allows you to change the AppInit + * function by using a #define of TCL_LOCAL_APPINIT instead + * of rewriting this entire file. The #if checks for that + * #define and uses Tcl_AppInit if it doesn't exist. + */ + +#ifndef TCL_LOCAL_APPINIT +#define TCL_LOCAL_APPINIT Tcl_AppInit +#endif + extern int TCL_LOCAL_APPINIT _ANSI_ARGS_((Tcl_Interp *interp)); + + /* + * The following #if block allows you to change how Tcl finds the startup + * script, prime the library or encoding paths, fiddle with the argv, + * etc., without needing to rewrite Tcl_Main() + */ + +#ifdef TCL_LOCAL_MAIN_HOOK + extern int TCL_LOCAL_MAIN_HOOK _ANSI_ARGS_((int *argc, char ***argv)); +#endif + #ifdef TCL_TEST /* * Pass the build time location of the tcl library (to find init.tcl) @@ -83,7 +105,12 @@ main(argc, argv) XtToolkitInitialize(); #endif - Tcl_Main(argc, argv, Tcl_AppInit); +#ifdef TCL_LOCAL_MAIN_HOOK + TCL_LOCAL_MAIN_HOOK(&argc, &argv); +#endif + + Tcl_Main(argc, argv, TCL_LOCAL_APPINIT); + return 0; /* Needed only to prevent compiler warning. */ } diff --git a/win/tclAppInit.c b/win/tclAppInit.c index d157656..b8f3e78 100644 --- a/win/tclAppInit.c +++ b/win/tclAppInit.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclAppInit.c,v 1.5 1999/04/16 00:48:07 stanton Exp $ + * RCS: @(#) $Id: tclAppInit.c,v 1.6 1999/12/02 02:03:37 redman Exp $ */ #include "tcl.h" @@ -54,6 +54,30 @@ main(argc, argv) char **argv; /* Values of command-line arguments. */ { /* + * The following #if block allows you to change the AppInit + * function by using a #define of TCL_LOCAL_APPINIT instead + * of rewriting this entire file. The #if checks for that + * #define and uses Tcl_AppInit if it doesn't exist. + */ + +#ifndef TCL_LOCAL_APPINIT +#define TCL_LOCAL_APPINIT Tcl_AppInit +#endif + extern int TCL_LOCAL_APPINIT _ANSI_ARGS_((Tcl_Interp *interp)); + + /* + * The following #if block allows you to change how Tcl finds the startup + * script, prime the library or encoding paths, fiddle with the argv, + * etc., without needing to rewrite Tcl_Main() + */ + +#ifdef TCL_LOCAL_MAIN_HOOK + extern int TCL_LOCAL_MAIN_HOOK _ANSI_ARGS_((int *argc, char ***argv)); +#endif + + char buffer[MAX_PATH +1]; + char *p; + /* * Set up the default locale to be standard "C" locale so parsing * is performed correctly. */ @@ -61,7 +85,25 @@ main(argc, argv) setlocale(LC_ALL, "C"); setargv(&argc, &argv); - Tcl_Main(argc, argv, Tcl_AppInit); + /* + * Replace argv[0] with full pathname of executable, and forward + * slashes substituted for backslashes. + */ + + GetModuleFileName(NULL, buffer, sizeof(buffer)); + argv[0] = buffer; + for (p = buffer; *p != '\0'; p++) { + if (*p == '\\') { + *p = '/'; + } + } + +#ifdef TCL_LOCAL_MAIN_HOOK + TCL_LOCAL_MAIN_HOOK(&argc, &argv); +#endif + + Tcl_Main(argc, argv, TCL_LOCAL_APPINIT); + return 0; /* Needed only to prevent compiler warning. */ } |