diff options
Diffstat (limited to 'generic')
| -rw-r--r-- | generic/tcl.decls | 7 | ||||
| -rw-r--r-- | generic/tclCmdMZ.c | 24 | ||||
| -rw-r--r-- | generic/tclDecls.h | 14 | ||||
| -rw-r--r-- | generic/tclIOUtil.c | 29 | ||||
| -rw-r--r-- | generic/tclInt.decls | 8 | ||||
| -rw-r--r-- | generic/tclIntDecls.h | 24 | ||||
| -rw-r--r-- | generic/tclMain.c | 152 | ||||
| -rw-r--r-- | generic/tclStubInit.c | 5 |
8 files changed, 218 insertions, 45 deletions
diff --git a/generic/tcl.decls b/generic/tcl.decls index fe9ceba..1e0edf4 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -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: tcl.decls,v 1.99 2003/08/25 20:06:04 dkf Exp $ +# RCS: @(#) $Id: tcl.decls,v 1.100 2003/09/05 21:52:11 dgp Exp $ library tcl @@ -1849,6 +1849,11 @@ declare 517 generic { Tcl_Obj *objPtr) } +# New export due to TIP#137 +declare 518 generic { + int Tcl_FSEvalFileEx(Tcl_Interp *interp, Tcl_Obj *fileName, + CONST char *encodingName) +} ############################################################################## # Define the platform specific public Tcl interface. These functions are diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 33fc59f..64fc82c 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdMZ.c,v 1.93 2003/07/04 10:30:27 dkf Exp $ + * RCS: @(#) $Id: tclCmdMZ.c,v 1.94 2003/09/05 21:52:11 dgp Exp $ */ #include "tclInt.h" @@ -1004,12 +1004,26 @@ Tcl_SourceObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "fileName"); + CONST char *encodingName = NULL; + Tcl_Obj *fileName; + + if (objc != 2 && objc !=4) { + Tcl_WrongNumArgs(interp, 1, objv, "?-encoding name? fileName"); return TCL_ERROR; } - - return Tcl_FSEvalFile(interp, objv[1]); + fileName = objv[objc-1]; + if (objc == 4) { + static CONST char *options[] = { + "-encoding", (char *) NULL + }; + int index; + if (TCL_ERROR == Tcl_GetIndexFromObj(interp, objv[1], + options, "option", TCL_EXACT, &index)) { + return TCL_ERROR; + } + encodingName = Tcl_GetString(objv[2]); + } + return Tcl_FSEvalFileEx(interp, fileName, encodingName); } /* diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 5fe4d18..40759c0 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -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: tclDecls.h,v 1.98 2003/08/25 21:05:15 dkf Exp $ + * RCS: @(#) $Id: tclDecls.h,v 1.99 2003/09/05 21:52:12 dgp Exp $ */ #ifndef _TCLDECLS @@ -3211,6 +3211,13 @@ EXTERN void Tcl_GetCommandFullName _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Command command, Tcl_Obj * objPtr)); #endif +#ifndef Tcl_FSEvalFileEx_TCL_DECLARED +#define Tcl_FSEvalFileEx_TCL_DECLARED +/* 518 */ +EXTERN int Tcl_FSEvalFileEx _ANSI_ARGS_((Tcl_Interp * interp, + Tcl_Obj * fileName, + CONST char * encodingName)); +#endif typedef struct TclStubHooks { struct TclPlatStubs *tclPlatStubs; @@ -3788,6 +3795,7 @@ typedef struct TclStubs { Tcl_Command (*tcl_FindCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_Namespace * contextNsPtr, int flags)); /* 515 */ Tcl_Command (*tcl_GetCommandFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 516 */ void (*tcl_GetCommandFullName) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command command, Tcl_Obj * objPtr)); /* 517 */ + int (*tcl_FSEvalFileEx) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * fileName, CONST char * encodingName)); /* 518 */ } TclStubs; #ifdef __cplusplus @@ -5900,6 +5908,10 @@ extern TclStubs *tclStubsPtr; #define Tcl_GetCommandFullName \ (tclStubsPtr->tcl_GetCommandFullName) /* 517 */ #endif +#ifndef Tcl_FSEvalFileEx +#define Tcl_FSEvalFileEx \ + (tclStubsPtr->tcl_FSEvalFileEx) /* 518 */ +#endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 1999598..e3013b9 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -17,7 +17,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIOUtil.c,v 1.82 2003/08/23 12:16:49 vasiljevic Exp $ + * RCS: @(#) $Id: tclIOUtil.c,v 1.83 2003/09/05 21:52:12 dgp Exp $ */ #include "tclInt.h" @@ -1363,10 +1363,20 @@ TclGetOpenMode(interp, string, seekFlagPtr) return mode; } +/* Tcl_FSEvalFile is Tcl_FSEvalFileEx without encoding argument */ +int +Tcl_FSEvalFile(interp, pathPtr) + Tcl_Interp *interp; /* Interpreter in which to process file. */ + Tcl_Obj *pathPtr; /* Path of file to process. Tilde-substitution + * will be performed on this name. */ +{ + return Tcl_FSEvalFileEx(interp, pathPtr, NULL); +} + /* *---------------------------------------------------------------------- * - * Tcl_FSEvalFile -- + * Tcl_FSEvalFileEx -- * * Read in a file and process the entire file as one gigantic * Tcl command. @@ -1385,10 +1395,11 @@ TclGetOpenMode(interp, string, seekFlagPtr) */ int -Tcl_FSEvalFile(interp, pathPtr) +Tcl_FSEvalFileEx(interp, pathPtr, encodingName) Tcl_Interp *interp; /* Interpreter in which to process file. */ Tcl_Obj *pathPtr; /* Path of file to process. Tilde-substitution * will be performed on this name. */ + CONST char *encodingName; { int result, length; Tcl_StatBuf statBuf; @@ -1426,6 +1437,18 @@ Tcl_FSEvalFile(interp, pathPtr) * [Bug: 2040] */ Tcl_SetChannelOption(interp, chan, "-eofchar", "\32"); + /* + * If the encoding is specified, set it for the channel. + * Else don't touch it (and use the system encoding) + * Report error on unknown encoding. + */ + if (encodingName) { + if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName) + != TCL_OK) { + Tcl_Close(interp,chan); + goto end; + } + } if (Tcl_ReadChars(chan, objPtr, -1, 0) < 0) { Tcl_Close(interp, chan); Tcl_AppendResult(interp, "couldn't read file \"", diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 9c00e01..f04bc4d 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -12,7 +12,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.62 2003/06/26 08:43:15 dkf Exp $ +# RCS: @(#) $Id: tclInt.decls,v 1.63 2003/09/05 21:52:12 dgp Exp $ library tcl @@ -719,6 +719,12 @@ declare 177 generic { CONST char *operation, CONST char *reason) } +declare 178 generic { + void Tcl_SetStartupScript(Tcl_Obj *pathPtr, CONST char* encodingName) +} +declare 179 generic { + Tcl_Obj *Tcl_GetStartupScript(CONST char **encodingNamePtr) +} ############################################################################## # Define the platform specific internal Tcl interface. These functions are diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index dc7af73..66e3e02 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.52 2003/08/25 21:05:15 dkf Exp $ + * RCS: @(#) $Id: tclIntDecls.h,v 1.53 2003/09/05 21:52:12 dgp Exp $ */ #ifndef _TCLINTDECLS @@ -937,6 +937,18 @@ EXTERN void TclVarErrMsg _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, CONST char * operation, CONST char * reason)); #endif +#ifndef Tcl_SetStartupScript_TCL_DECLARED +#define Tcl_SetStartupScript_TCL_DECLARED +/* 178 */ +EXTERN void Tcl_SetStartupScript _ANSI_ARGS_((Tcl_Obj * pathPtr, + CONST char* encodingName)); +#endif +#ifndef Tcl_GetStartupScript_TCL_DECLARED +#define Tcl_GetStartupScript_TCL_DECLARED +/* 179 */ +EXTERN Tcl_Obj * Tcl_GetStartupScript _ANSI_ARGS_(( + CONST char ** encodingNamePtr)); +#endif typedef struct TclIntStubs { int magic; @@ -1144,6 +1156,8 @@ typedef struct TclIntStubs { int (*tclCallVarTraces) _ANSI_ARGS_((Interp * iPtr, Var * arrayPtr, Var * varPtr, CONST char * part1, CONST char * part2, int flags, int leaveErrMsg)); /* 175 */ void (*tclCleanupVar) _ANSI_ARGS_((Var * varPtr, Var * arrayPtr)); /* 176 */ void (*tclVarErrMsg) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, CONST char * operation, CONST char * reason)); /* 177 */ + void (*tcl_SetStartupScript) _ANSI_ARGS_((Tcl_Obj * pathPtr, CONST char* encodingName)); /* 178 */ + Tcl_Obj * (*tcl_GetStartupScript) _ANSI_ARGS_((CONST char ** encodingNamePtr)); /* 179 */ } TclIntStubs; #ifdef __cplusplus @@ -1770,6 +1784,14 @@ extern TclIntStubs *tclIntStubsPtr; #define TclVarErrMsg \ (tclIntStubsPtr->tclVarErrMsg) /* 177 */ #endif +#ifndef Tcl_SetStartupScript +#define Tcl_SetStartupScript \ + (tclIntStubsPtr->tcl_SetStartupScript) /* 178 */ +#endif +#ifndef Tcl_GetStartupScript +#define Tcl_GetStartupScript \ + (tclIntStubsPtr->tcl_GetStartupScript) /* 179 */ +#endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclMain.c b/generic/tclMain.c index 1380ce8..1065951 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.20 2002/05/29 22:59:33 dgp Exp $ + * RCS: @(#) $Id: tclMain.c,v 1.21 2003/09/05 21:52:12 dgp Exp $ */ #include "tcl.h" @@ -32,6 +32,7 @@ extern int isatty _ANSI_ARGS_((int fd)); #endif static Tcl_Obj *tclStartupScriptPath = NULL; +static Tcl_Obj *tclStartupScriptEncoding = NULL; static Tcl_MainLoopProc *mainLoopProc = NULL; @@ -73,32 +74,102 @@ static void StdinProc _ANSI_ARGS_((ClientData clientData, /* *---------------------------------------------------------------------- * - * TclSetStartupScriptPath -- + * Tcl_SetStartupScript -- * - * Primes the startup script VFS path, used to override the - * command line processing. + * Sets the path and encoding of the startup script to be evaluated + * by Tcl_Main, used to override the command line processing. * * Results: * None. * * Side effects: - * This procedure initializes the VFS path of the Tcl script to - * run at startup. * *---------------------------------------------------------------------- */ -void TclSetStartupScriptPath(pathPtr) - Tcl_Obj *pathPtr; +void Tcl_SetStartupScript(path, encoding) + Tcl_Obj *path; /* Filesystem path of startup script file */ + CONST char *encoding; /* Encoding of the data in that file */ { + Tcl_Obj *newEncoding = NULL; + if (encoding != NULL) { + newEncoding = Tcl_NewStringObj(encoding, -1); + } + if (tclStartupScriptPath != NULL) { Tcl_DecrRefCount(tclStartupScriptPath); } - tclStartupScriptPath = pathPtr; + tclStartupScriptPath = path; if (tclStartupScriptPath != NULL) { Tcl_IncrRefCount(tclStartupScriptPath); } + + if (tclStartupScriptEncoding != NULL) { + Tcl_DecrRefCount(tclStartupScriptEncoding); + } + tclStartupScriptEncoding = newEncoding; + if (tclStartupScriptEncoding != NULL) { + Tcl_IncrRefCount(tclStartupScriptEncoding); + } } + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetStartupScript -- + * + * Gets the path and encoding of the startup script to be evaluated + * by Tcl_Main. + * + * Results: + * The path of the startup script; NULL if none has been set. + * + * Side effects: + * If encodingPtr is not NULL, stores a (CONST char *) in it + * pointing to the encoding name registered for the startup + * script. Tcl retains ownership of the string, and may free + * it. Caller should make a copy for long-term use. + * + *---------------------------------------------------------------------- + */ +Tcl_Obj *Tcl_GetStartupScript(encodingPtr) + CONST char** encodingPtr; /* When not NULL, points to storage for + * the (CONST char *) that points to the + * registered encoding name for the startup + * script */ +{ + if (encodingPtr != NULL) { + if (tclStartupScriptEncoding == NULL) { + *encodingPtr = NULL; + } else { + *encodingPtr = Tcl_GetString(tclStartupScriptEncoding); + } + } + return tclStartupScriptPath; +} + +/* + *---------------------------------------------------------------------- + * + * TclSetStartupScriptPath -- + * + * Primes the startup script VFS path, used to override the + * command line processing. + * + * Results: + * None. + * + * Side effects: + * This procedure initializes the VFS path of the Tcl script to + * run at startup. + * + *---------------------------------------------------------------------- + */ +void TclSetStartupScriptPath(path) + Tcl_Obj *path; +{ + Tcl_SetStartupScript(path, NULL); +} /* *---------------------------------------------------------------------- @@ -118,10 +189,9 @@ void TclSetStartupScriptPath(pathPtr) */ Tcl_Obj *TclGetStartupScriptPath() { - return tclStartupScriptPath; + return Tcl_GetStartupScript(NULL); } - /* *---------------------------------------------------------------------- * @@ -142,8 +212,8 @@ Tcl_Obj *TclGetStartupScriptPath() void TclSetStartupScriptFileName(fileName) CONST char *fileName; { - Tcl_Obj *pathPtr = Tcl_NewStringObj(fileName,-1); - TclSetStartupScriptPath(pathPtr); + Tcl_Obj *path = Tcl_NewStringObj(fileName,-1); + Tcl_SetStartupScript(path, NULL); } @@ -165,15 +235,14 @@ void TclSetStartupScriptFileName(fileName) */ CONST char *TclGetStartupScriptFileName() { - Tcl_Obj *pathPtr = TclGetStartupScriptPath(); + Tcl_Obj *path = Tcl_GetStartupScript(NULL); - if (pathPtr == NULL) { + if (path == NULL) { return NULL; } - return Tcl_GetString(pathPtr); + return Tcl_GetString(path); } - /* *---------------------------------------------------------------------- @@ -204,8 +273,10 @@ Tcl_Main(argc, argv, appInitProc) * initialization but before starting to * execute commands. */ { + Tcl_Obj *path; Tcl_Obj *resultPtr; Tcl_Obj *commandPtr = NULL; + CONST char *encodingName = NULL; char buffer[TCL_INTEGER_SPACE + 5], *args; PromptType prompt = PROMPT_START; int code, length, tty; @@ -220,14 +291,27 @@ Tcl_Main(argc, argv, appInitProc) Tcl_InitMemory(interp); /* - * Make command-line arguments available in the Tcl variables "argc" - * and "argv". If the first argument doesn't start with a "-" then - * strip it off and use it as the name of a script file to process. + * If the application has not already set a startup script, parse + * the first few command line arguments to determine the script + * path and encoding. */ - if (TclGetStartupScriptPath() == NULL) { - if ((argc > 1) && (argv[1][0] != '-')) { - TclSetStartupScriptFileName(argv[1]); + if (NULL == Tcl_GetStartupScript(NULL)) { + + /* + * Check whether first 3 args (argv[1] - argv[3]) look like + * -encoding ENCODING FILENAME + * or like + * FILENAME + */ + + if ((argc > 3) && (0 == strcmp("-encoding", argv[1])) + && ('-' != argv[3][0])) { + Tcl_SetStartupScript(Tcl_NewStringObj(argv[3], -1), argv[2]); + argc -= 3; + argv += 3; + } else if ((argc > 1) && ('-' != argv[1][0])) { + Tcl_SetStartupScript(Tcl_NewStringObj(argv[1], -1), NULL); argc--; argv++; } @@ -245,11 +329,14 @@ Tcl_Main(argc, argv, appInitProc) Tcl_DStringFree(&argString); ckfree(args); - if (TclGetStartupScriptPath() == NULL) { + path = Tcl_GetStartupScript(&encodingName); + if (path == NULL) { Tcl_ExternalToUtfDString(NULL, argv[0], -1, &argString); } else { - TclSetStartupScriptFileName(Tcl_ExternalToUtfDString(NULL, - TclGetStartupScriptFileName(), -1, &argString)); + CONST char *pathName = Tcl_GetStringFromObj(path, &length); + Tcl_ExternalToUtfDString(NULL, pathName, length, &argString); + path = Tcl_NewStringObj(Tcl_DStringValue(&argString), -1); + Tcl_SetStartupScript(path, encodingName); } TclFormatInt(buffer, (long) argc-1); @@ -261,8 +348,7 @@ Tcl_Main(argc, argv, appInitProc) */ tty = isatty(0); - Tcl_SetVar(interp, "tcl_interactive", - ((TclGetStartupScriptPath() == NULL) && tty) ? "1" : "0", + Tcl_SetVar(interp, "tcl_interactive", ((path == NULL) && tty) ? "1" : "0", TCL_GLOBAL_ONLY); /* @@ -285,11 +371,13 @@ Tcl_Main(argc, argv, appInitProc) /* * If a script file was specified then just source that file - * and quit. + * and quit. Must fetch it again, as the appInitProc might + * have reset it. */ - if (TclGetStartupScriptPath() != NULL) { - code = Tcl_FSEvalFile(interp, TclGetStartupScriptPath()); + path = Tcl_GetStartupScript(&encodingName); + if (path != NULL) { + code = Tcl_FSEvalFileEx(interp, path, encodingName); if (code != TCL_OK) { errChannel = Tcl_GetStdChannel(TCL_STDERR); if (errChannel) { @@ -510,7 +598,7 @@ Tcl_Main(argc, argv, appInitProc) Tcl_DeleteInterp(interp); } } - TclSetStartupScriptPath(NULL); + Tcl_SetStartupScript(NULL, NULL); /* * If we get here, the master interp has been deleted. Allow diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 4f75d4c..ef5d8f1 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.87 2003/08/25 20:06:37 dkf Exp $ + * RCS: @(#) $Id: tclStubInit.c,v 1.88 2003/09/05 21:52:12 dgp Exp $ */ #include "tclInt.h" @@ -272,6 +272,8 @@ TclIntStubs tclIntStubs = { TclCallVarTraces, /* 175 */ TclCleanupVar, /* 176 */ TclVarErrMsg, /* 177 */ + Tcl_SetStartupScript, /* 178 */ + Tcl_GetStartupScript, /* 179 */ }; TclIntPlatStubs tclIntPlatStubs = { @@ -960,6 +962,7 @@ TclStubs tclStubs = { Tcl_FindCommand, /* 515 */ Tcl_GetCommandFromObj, /* 516 */ Tcl_GetCommandFullName, /* 517 */ + Tcl_FSEvalFileEx, /* 518 */ }; /* !END!: Do not edit above this line. */ |