diff options
author | dgp <dgp@users.sourceforge.net> | 2003-09-05 21:52:11 (GMT) |
---|---|---|
committer | dgp <dgp@users.sourceforge.net> | 2003-09-05 21:52:11 (GMT) |
commit | c024a2de4b3868a69fd48901c50a0beedb49ed9d (patch) | |
tree | d3430b36c25b01800aa40d815fadb9629ef33770 | |
parent | 4383bd1bfc3daa1d69ddcb095a35c5e723f1ba6b (diff) | |
download | tcl-c024a2de4b3868a69fd48901c50a0beedb49ed9d.zip tcl-c024a2de4b3868a69fd48901c50a0beedb49ed9d.tar.gz tcl-c024a2de4b3868a69fd48901c50a0beedb49ed9d.tar.bz2 |
* doc/FileSystem.3: Implementation of
* doc/source.n: TIPs 137/151. Adds
* doc/tclsh.1: a -encoding option to
* generic/tcl.decls: the [source] command
* generic/tclCmdMZ.c (Tcl_SourceObjCmd): and a new C routine,
* generic/tclIOUtil.c (Tcl_FSEvalFileEx): Tcl_FSEvalFileEx(),
* generic/tclMain.c (Tcl_Main): that provides C access
* mac/tclMacResource.c (Tcl_MacSourceObjCmd): to the same function.
* tests/cmdMZ.test: Also adds command line
* tests/main.test: option handling in Tcl_Main() so that tclsh
* tests/source.test: and other apps built on Tcl_Main() respect
a -encoding command line option before a script filename. Docs and
tests updated as well. [Patch 742683]
This is a ***POTENTIAL INCOMPATIBILITY*** only for those C programs
that embed Tcl, build on Tcl_Main(), and make use of Tcl_Main's former
ability to pass a leading "-encoding" option to interactive shell
operations.
* generic/tclInt.decls: Added internal stub
* generic/tclMain.c (Tcl*StartupScript*): table entries for
two new functions Tcl_SetStartupScript() and Tcl_GetStartupScript()
that set/get the path and encoding for the startup script to be
evaluated by either Tcl_Main() or Tk_Main(). Given public names in
anticipation of their exposure by a followup TIP.
* generic/tclDecls.h: make genstubs
* generic/tclIntDecls.h:
* generic/tclStubInit.c:
-rw-r--r-- | ChangeLog | 31 | ||||
-rw-r--r-- | doc/FileSystem.3 | 26 | ||||
-rw-r--r-- | doc/source.n | 16 | ||||
-rw-r--r-- | doc/tclsh.1 | 20 | ||||
-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 | ||||
-rw-r--r-- | mac/tclMacResource.c | 15 | ||||
-rw-r--r-- | tests/cmdMZ.test | 15 | ||||
-rw-r--r-- | tests/main.test | 68 | ||||
-rw-r--r-- | tests/source.test | 416 |
16 files changed, 687 insertions, 183 deletions
@@ -1,5 +1,36 @@ 2003-09-04 Don Porter <dgp@users.sourceforge.net> + * doc/FileSystem.3: Implementation of + * doc/source.n: TIPs 137/151. Adds + * doc/tclsh.1: a -encoding option to + * generic/tcl.decls: the [source] command + * generic/tclCmdMZ.c (Tcl_SourceObjCmd): and a new C routine, + * generic/tclIOUtil.c (Tcl_FSEvalFileEx): Tcl_FSEvalFileEx(), + * generic/tclMain.c (Tcl_Main): that provides C access + * mac/tclMacResource.c (Tcl_MacSourceObjCmd): to the same function. + * tests/cmdMZ.test: Also adds command line + * tests/main.test: option handling in Tcl_Main() so that tclsh + * tests/source.test: and other apps built on Tcl_Main() respect + a -encoding command line option before a script filename. Docs and + tests updated as well. [Patch 742683] + This is a ***POTENTIAL INCOMPATIBILITY*** only for those C programs + that embed Tcl, build on Tcl_Main(), and make use of Tcl_Main's former + ability to pass a leading "-encoding" option to interactive shell + operations. + + * generic/tclInt.decls: Added internal stub + * generic/tclMain.c (Tcl*StartupScript*): table entries for + two new functions Tcl_SetStartupScript() and Tcl_GetStartupScript() + that set/get the path and encoding for the startup script to be + evaluated by either Tcl_Main() or Tk_Main(). Given public names in + anticipation of their exposure by a followup TIP. + + * generic/tclDecls.h: make genstubs + * generic/tclIntDecls.h: + * generic/tclStubInit.c: + +2003-09-04 Don Porter <dgp@users.sourceforge.net> + * doc/SplitList.3: Implementation of TIP 148. Fixes [Bug 489537]. * generic/tcl.h: Updated Tcl_ConvertCountedElement() to quote * generic/tclUtil.c: the leading "#" character of all list elements diff --git a/doc/FileSystem.3 b/doc/FileSystem.3 index c7113b9..acfb093 100644 --- a/doc/FileSystem.3 +++ b/doc/FileSystem.3 @@ -4,7 +4,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: FileSystem.3,v 1.34 2003/07/28 12:16:02 vincentdarley Exp $ +'\" RCS: @(#) $Id: FileSystem.3,v 1.35 2003/09/05 21:52:11 dgp Exp $ '\" .so man.macros .TH Filesystem 3 8.4 Tcl "Tcl Library Procedures" @@ -28,10 +28,10 @@ void \fBTcl_FSMountsChanged\fR(\fIfsPtr\fR) .sp Tcl_Filesystem* -\fBTcl_FSGetFileSystemForPath\fR(\fIpathObjPtr\fR) +\fBTcl_FSGetFileSystemForPath\fR(\fIpathPtr\fR) .sp Tcl_PathType -\fBTcl_FSGetPathType\fR(\fIpathObjPtr\fR) +\fBTcl_FSGetPathType\fR(\fIpathPtr\fR) .sp int \fBTcl_FSCopyFile\fR(\fIsrcPathPtr, destPathPtr\fR) @@ -54,6 +54,11 @@ int Tcl_Obj* \fBTcl_FSListVolumes\fR(\fIvoid\fR) .sp +.VS 8.5 +int +\fBTcl_FSEvalFileEx\fR(\fIinterp, pathPtr, encodingName\fR) +.VE 8.5 +.sp int \fBTcl_FSEvalFile\fR(\fIinterp, pathPtr\fR) .sp @@ -138,7 +143,7 @@ Tcl_Obj* Tcl_StatBuf* \fBTcl_AllocStatBuf\fR() .SH ARGUMENTS -.AS Tcl_Filesystem *fsPtr in +.AS "CONST char" *encodingName in .AP Tcl_Filesystem *fsPtr in Points to a structure containing the addresses of procedures that can be called to perform the various filesystem operations. @@ -152,6 +157,9 @@ rename operation. .AP Tcl_Obj *destPathPtr in As for \fBpathPtr\fR, but used for the destination filename for a copy or rename operation. +.AP "CONST char" *encodingName in +The encoding of the data stored in the +file identified by \fBpathPtr\fR and to be evaluted. .AP "CONST char" *pattern in Only files or directories matching this pattern will be returned by \fBTcl_FSMatchInDirectory\fR. @@ -314,15 +322,23 @@ volumes' function and asks them to return their list of root volumes. It accumulates the return values in a list which is returned to the caller (with a refCount of 0). .PP -\fBTcl_FSEvalFile\fR reads the file given by \fIpathPtr\fR and evaluates +.VS 8.5 +\fBTcl_FSEvalFileEx\fR reads the file given by \fIpathPtr\fR using +the encoding identified by \fBencodingName\fR and evaluates its contents as a Tcl script. It returns the same information as \fBTcl_EvalObjEx\fR. +If \fBencodingName\fR is NULL, the system encoding is used for +reading the file contents. If the file couldn't be read then a Tcl error is returned to describe why the file couldn't be read. The eofchar for files is '\\32' (^Z) for all platforms. If you require a ``^Z'' in code for string comparison, you can use ``\\032'' or ``\\u001a'', which will be safely substituted by the Tcl interpreter into ``^Z''. +\fBTcl_FSEvalFile\fR is a simpler version of +\fBTcl_FSEvalFileEx\fR that always uses the system encoding +when reading the file. +.VE 8.5 .PP \fBTcl_FSLoadFile\fR dynamically loads a binary code file into memory and returns the addresses of two procedures within that file, if they are diff --git a/doc/source.n b/doc/source.n index 7276a9c..ffc04ab 100644 --- a/doc/source.n +++ b/doc/source.n @@ -6,7 +6,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: source.n,v 1.5 2000/09/07 14:27:51 poenitz Exp $ +'\" RCS: @(#) $Id: source.n,v 1.6 2003/09/05 21:52:11 dgp Exp $ '\" .so man.macros .TH source n "" Tcl "Tcl Built-In Commands" @@ -17,6 +17,10 @@ source \- Evaluate a file or resource as a Tcl script .SH SYNOPSIS \fBsource \fIfileName\fR .sp +.VS 8.5 +\fBsource\fR \fB\-encoding \fIencodingName fileName\fR +.VE 8.5 +.sp \fBsource\fR \fB\-rsrc \fIresourceName \fR?\fIfileName\fR? .sp \fBsource\fR \fB\-rsrcid \fIresourceId \fR?\fIfileName\fR? @@ -33,7 +37,6 @@ If a \fBreturn\fR command is invoked from within the script then the remainder of the file will be skipped and the \fBsource\fR command will return normally with the result from the \fBreturn\fR command. .PP -.VS 8.4 The end-of-file character for files is '\\32' (^Z) for all platforms. The source command will read files up to this character. This restriction does not exist for the \fBread\fR or \fBgets\fR commands, @@ -41,7 +44,12 @@ allowing for files containing code and data segments (scripted documents). If you require a ``^Z'' in code for string comparison, you can use ``\\032'' or ``\\u001a'', which will be safely substituted by the Tcl interpreter into ``^Z''. -.VE 8.4 +.PP +.VS 8.5 +The \fB-encoding\fR option is used to specify the encoding of +the data stored in \fIfileName\fR. When the \fB-encoding\fR option +is omitted, the system encoding is assumed. +.VE 8.5 .PP The \fI\-rsrc\fR and \fI\-rsrcid\fR forms of this command are only available on Macintosh computers. These versions of the command @@ -52,7 +60,7 @@ application and any loaded C extensions. Alternatively, you may specify the \fIfileName\fR where the \fBTEXT\fR resource can be found. .SH "SEE ALSO" -file(n), cd(n) +file(n), cd(n), encoding(n) .SH KEYWORDS file, script diff --git a/doc/tclsh.1 b/doc/tclsh.1 index bda9e5e..ea3af4c 100644 --- a/doc/tclsh.1 +++ b/doc/tclsh.1 @@ -5,7 +5,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: tclsh.1,v 1.8 2003/02/13 22:03:34 kennykb Exp $ +'\" RCS: @(#) $Id: tclsh.1,v 1.9 2003/09/05 21:52:11 dgp Exp $ '\" .so man.macros .TH tclsh 1 "" Tcl "Tcl Applications" @@ -14,7 +14,7 @@ .SH NAME tclsh \- Simple shell containing Tcl interpreter .SH SYNOPSIS -\fBtclsh\fR ?\fIfileName arg arg ...\fR? +\fBtclsh\fR ?-encoding \fIname\fR? ?\fIfileName arg arg ...\fR? .BE .SH DESCRIPTION @@ -28,18 +28,21 @@ It runs until the \fBexit\fR command is invoked or until it reaches end-of-file on its standard input. If there exists a file \fB.tclshrc\fR (or \fBtclshrc.tcl\fR on the Windows platforms) in the home directory of -the user, \fBtclsh\fR evaluates the file as a Tcl script +the user, interactive \fBtclsh\fR evaluates the file as a Tcl script just before reading the first command from standard input. .SH "SCRIPT FILES" .PP -If \fBtclsh\fR is invoked with arguments then the first argument -is the name of a script file and any additional arguments +.VS 8.5 +If \fBtclsh\fR is invoked with arguments then the first few arguments +specify the name of a script file, and, optionally, the encoding of +the text data stored in that script file. +.VE 8.5 +Any additional arguments are made available to the script as variables (see below). Instead of reading commands from standard input \fBtclsh\fR will read Tcl commands from the named file; \fBtclsh\fR will exit when it reaches the end of the file. -.VS 8.4 The end of the file may be marked either by the physical end of the medium, or by the character, '\\032' ('\\u001a', control-Z). If this character is present in the file, the \fBtclsh\fR application @@ -47,7 +50,6 @@ will read text up to but not including the character. An application that requires this character in the file may safely encode it as ``\\032'', ``\\x1a'', or ``\\u001a''; or may generate it by use of commands such as \fBformat\fR or \fBbinary\fR. -.VE There is no automatic evaluation of \fB.tclshrc\fR when the name of a script file is presented on the \fBtclsh\fR command line, but the script file can always \fBsource\fR it if desired. @@ -91,13 +93,11 @@ When \fBtclsh\fR starts up, it treats all three lines as comments, since the backslash at the end of the second line causes the third line to be treated as part of the comment on the second line. .PP -.VS You should note that it is also common practise to install tclsh with its version number as part of the name. This has the advantage of allowing multiple versions of Tcl to exist on the same system at once, but also the disadvantage of making it harder to write scripts that start up uniformly across different versions of Tcl. -.VE .SH "VARIABLES" .PP @@ -138,7 +138,7 @@ incomplete commands. See \fBTcl_StandardChannels\fR for more explanations. .SH "SEE ALSO" -fconfigure(n), tclvars(n) +encoding(n), fconfigure(n), tclvars(n) .SH KEYWORDS argument, interpreter, prompt, script file, shell 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. */ diff --git a/mac/tclMacResource.c b/mac/tclMacResource.c index 49e1110..3833a65 100644 --- a/mac/tclMacResource.c +++ b/mac/tclMacResource.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: tclMacResource.c,v 1.15 2003/05/14 19:21:24 das Exp $ + * RCS: @(#) $Id: tclMacResource.c,v 1.16 2003/09/05 21:52:12 dgp Exp $ */ #include <Errors.h> @@ -946,6 +946,7 @@ Tcl_MacSourceObjCmd( char *fileName = NULL, *rsrcName = NULL; long rsrcID = -1; char *string; + char *encodingName = NULL; int length; if (objc < 2 || objc > 4) { @@ -968,6 +969,10 @@ Tcl_MacSourceObjCmd( if (Tcl_GetLongFromObj(interp, objv[2], &rsrcID) != TCL_OK) { return TCL_ERROR; } + } else if (!strcmp(string, "-encoding")) { + if (objc != 4) + goto sourceFmtErr; + encodingName = Tcl_GetString(objv[2]); } else { errStr = errBad; goto sourceFmtErr; @@ -976,13 +981,19 @@ Tcl_MacSourceObjCmd( if (objc == 4) { fileName = Tcl_GetStringFromObj(objv[3], &length); } + + if (encodingName) { + return Tcl_FSEvalFileEx(interp, fileName, encodingName); + } + return Tcl_MacEvalResource(interp, rsrcName, rsrcID, fileName); sourceFmtErr: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), errStr, "should be \"", Tcl_GetString(objv[0]), " fileName\" or \"", Tcl_GetString(objv[0]), " -rsrc name ?fileName?\" or \"", - Tcl_GetString(objv[0]), " -rsrcid id ?fileName?\"", + Tcl_GetString(objv[0]), " -rsrcid id ?fileName?\" or \"", + Tcl_GetString(objv[0]), " -encoding name fileName\"", (char *) NULL); return TCL_ERROR; } diff --git a/tests/cmdMZ.test b/tests/cmdMZ.test index 4609365..2e2a978 100644 --- a/tests/cmdMZ.test +++ b/tests/cmdMZ.test @@ -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: cmdMZ.test,v 1.17 2003/08/29 17:43:24 dgp Exp $ +# RCS: @(#) $Id: cmdMZ.test,v 1.18 2003/09/05 21:52:12 dgp Exp $ if {[catch {package require tcltest 2.0.2}]} { puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required." @@ -187,6 +187,7 @@ foreach script { # The tests for Tcl_ScanObjCmd are in scan.test # Tcl_SourceObjCmd +# More tests of Tcl_SourceObjCmd are in source.test test cmdMZ-3.1 {Tcl_SourceObjCmd: error conditions} {macOnly} { list [catch {source} msg] $msg @@ -194,12 +195,16 @@ test cmdMZ-3.1 {Tcl_SourceObjCmd: error conditions} {macOnly} { test cmdMZ-3.2 {Tcl_SourceObjCmd: error conditions} {macOnly} { list [catch {source a b} msg] $msg } {1 {bad argument: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?"}} -test cmdMZ-3.3 {Tcl_SourceObjCmd: error conditions} {unixOrPc} { +test cmdMZ-3.3 {Tcl_SourceObjCmd: error conditions} -constraints { + unixOrPc +} -body { list [catch {source} msg] $msg -} {1 {wrong # args: should be "source fileName"}} -test cmdMZ-3.4 {Tcl_SourceObjCmd: error conditions} {unixOrPc} { +} -match glob -result {1 {wrong # args: should be "source*fileName"}} +test cmdMZ-3.4 {Tcl_SourceObjCmd: error conditions} -constraints { + unixOrPc +} -body { list [catch {source a b} msg] $msg -} {1 {wrong # args: should be "source fileName"}} +} -match glob -result {1 {wrong # args: should be "source*fileName"}} test cmdMZ-3.5 {Tcl_SourceObjCmd: error in script} -body { set file [makeFile { set x 146 diff --git a/tests/main.test b/tests/main.test index 6778b88..605bab8 100644 --- a/tests/main.test +++ b/tests/main.test @@ -1,6 +1,6 @@ # This file contains a collection of tests for generic/tclMain.c. # -# RCS: @(#) $Id: main.test,v 1.13 2003/02/16 01:36:32 msofer Exp $ +# RCS: @(#) $Id: main.test,v 1.14 2003/09/05 21:52:12 dgp Exp $ if {[catch {package require tcltest 2.0.2}]} { puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required." @@ -139,6 +139,72 @@ namespace eval ::tcl::test::main { } -result [list [list [encoding convertfrom [encoding system] \ [encoding convertto [encoding system] \u20ac]]] {} 0]\n + test Tcl_Main-1.7 { + Tcl_Main: startup script - -encoding option + } -constraints { + stdio + } -setup { + set script [makeFile {} script] + removeFile script + set f [open $script w] + fconfigure $f -encoding utf-8 + puts $f {puts [list $argv0 $argv $tcl_interactive]} + puts -nonewline $f {puts [string equal \u20ac } + puts $f "\u20ac]" + close $f + catch {set f [open "|[list [interpreter] -encoding utf-8 script]" r]} + } -body { + read $f + } -cleanup { + close $f + removeFile script + } -result [list script {} 0]\n1\n + + test Tcl_Main-1.8 { + Tcl_Main: startup script - -encoding option - mismatched encodings + } -constraints { + stdio + } -setup { + set script [makeFile {} script] + removeFile script + set f [open $script w] + fconfigure $f -encoding utf-8 + puts $f {puts [list $argv0 $argv $tcl_interactive]} + puts -nonewline $f {puts [string equal \u20ac } + puts $f "\u20ac]" + close $f + catch {set f [open "|[list [interpreter] -encoding ascii script]" r]} + } -body { + read $f + } -cleanup { + close $f + removeFile script + } -result [list script {} 0]\n0\n + + test Tcl_Main-1.9 { + Tcl_Main: startup script - -encoding option - no abbrevation + } -constraints { + stdio + } -setup { + set script [makeFile {} script] + removeFile script + set f [open $script w] + fconfigure $f -encoding utf-8 + puts $f {puts [list $argv0 $argv $tcl_interactive]} + puts -nonewline $f {puts [string equal \u20ac } + puts $f "\u20ac]" + close $f + catch {set f [open "|[list [interpreter] -enc utf-8 script]" r+]} + } -body { + type $f { + puts $argv + } + list [catch {gets $f} line] $line + } -cleanup { + close $f + removeFile script + } -result {0 {-enc utf-8 script}} + # Tests Tcl_Main-2.*: application-initialization procedure test Tcl_Main-2.1 { diff --git a/tests/source.test b/tests/source.test index f245d05..413c658 100644 --- a/tests/source.test +++ b/tests/source.test @@ -7,187 +7,381 @@ # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. # Copyright (c) 1998-2000 by Scriptics Corporation. +# Contributions from Don Porter, NIST, 2003. (not subject to US copyright) # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: source.test,v 1.8 2002/07/05 10:38:43 dkf Exp $ +# RCS: @(#) $Id: source.test,v 1.9 2003/09/05 21:52:12 dgp Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import -force ::tcltest::* +if {[catch {package require tcltest 2.0.2}]} { + puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required." + return } -set sourcefile [makeFile "" source.file] -test source-1.1 {source command} { +namespace eval ::tcl::test::source { + namespace import ::tcltest::test + namespace import ::tcltest::testConstraint + namespace import ::tcltest::cleanupTests + namespace import ::tcltest::makeFile + namespace import ::tcltest::removeFile + +test source-1.1 {source command} -setup { set x "old x value" set y "old y value" set z "old z value" - makeFile { + set sourcefile [makeFile { set x 22 set y 33 set z 44 - } source.file + } source.file] +} -body { source $sourcefile list $x $y $z -} {22 33 44} -test source-1.2 {source command} { - makeFile {list result} source.file +} -cleanup { + removeFile source.file +} -result {22 33 44} + +test source-1.2 {source command} -setup { + set sourcefile [makeFile {list result} source.file] +} -body { source $sourcefile -} result -test source-1.3 {source command} { - set y {\ } +} -cleanup { + removeFile source.file +} -result result +test source-1.3 {source command} -setup { + set sourcefile [makeFile {} source.file] set fd [open $sourcefile w] fconfigure $fd -translation lf - puts -nonewline $fd "list a b c " - puts $fd [string index $y 0] + puts $fd "list a b c \\" puts $fd "d e f" close $fd - +} -body { source $sourcefile -} {a b c d e f} +} -cleanup { + removeFile source.file +} -result {a b c d e f} -test source-2.3 {source error conditions} { - makeFile { + +test source-2.3 {source error conditions} -setup { + set sourcefile [makeFile { set x 146 error "error in sourced file" set y $x - } source.file - list [catch {source $sourcefile} msg] $msg $errorInfo -} [list 1 {error in sourced file} "error in sourced file + } source.file] +} -body { + list [catch {source $sourcefile} msg] $msg $::errorInfo +} -cleanup { + removeFile source.file +} -match glob -result [list 1 {error in sourced file} \ + {error in sourced file while executing -\"error \"error in sourced file\"\" - (file \"$sourcefile\" line 3) +"error "error in sourced file"" + (file "*source.file" line 3) invoked from within -\"source \$sourcefile\""] -test source-2.4 {source error conditions} { - makeFile {break} source.file - catch {source $sourcefile} -} 3 -test source-2.5 {source error conditions} { - makeFile {continue} source.file - catch {source $sourcefile} -} 4 -test source-2.6 {source error conditions} { - normalizeMsg [list [catch {source _non_existent_} msg] $msg $errorCode] -} {1 {couldn't read file "_non_existent_": no such file or directory} {posix enoent {no such file or directory}}} - -test source-3.1 {return in middle of source file} { - makeFile { +"source $sourcefile"}] + +test source-2.4 {source error conditions} -setup { + set sourcefile [makeFile {break} source.file] +} -body { + source $sourcefile +} -cleanup { + removeFile source.file +} -returnCodes break + +test source-2.5 {source error conditions} -setup { + set sourcefile [makeFile {continue} source.file] +} -body { + source $sourcefile +} -cleanup { + removeFile source.file +} -returnCodes continue + +test source-2.6 {source error conditions} -setup { + set sourcefile [makeFile {} _non_existent_] + removeFile _non_existent_ +} -body { + list [catch {source $sourcefile} msg] $msg $::errorCode +} -match glob -result [list 1 \ + {couldn't read file "*_non_existent_": no such file or directory} \ + {POSIX ENOENT {no such file or directory}}] + + +test source-3.1 {return in middle of source file} -setup { + set sourcefile [makeFile { set x new-x return allDone set y new-y - } source.file + } source.file] +} -body { set x old-x set y old-y set z [source $sourcefile] list $x $y $z -} {new-x old-y allDone} -test source-3.2 {return with special code etc.} { - makeFile { +} -cleanup { + removeFile source.file +} -result {new-x old-y allDone} + +test source-3.2 {return with special code etc.} -setup { + set sourcefile [makeFile { set x new-x return -code break "Silly result" set y new-y - } source.file - list [catch {source $sourcefile} msg] $msg -} {3 {Silly result}} -test source-3.3 {return with special code etc.} { - makeFile { + } source.file] +} -body { + source $sourcefile +} -cleanup { + removeFile source.file +} -returnCodes break -result {Silly result} + +test source-3.3 {return with special code etc.} -setup { + set sourcefile [makeFile { set x new-x return -code error "Simulated error" set y new-y - } source.file - list [catch {source $sourcefile} msg] $msg $errorInfo $errorCode -} {1 {Simulated error} {Simulated error + } source.file] +} -body { + list [catch {source $sourcefile} msg] $msg $::errorInfo $::errorCode +} -cleanup { + removeFile source.file +} -result {1 {Simulated error} {Simulated error while executing "source $sourcefile"} NONE} -test source-3.4 {return with special code etc.} { - makeFile { + +test source-3.4 {return with special code etc.} -setup { + set sourcefile [makeFile { set x new-x return -code error -errorinfo "Simulated errorInfo stuff" set y new-y - } source.file - list [catch {source $sourcefile} msg] $msg $errorInfo $errorCode -} {1 {} {Simulated errorInfo stuff + } source.file] +} -body { + list [catch {source $sourcefile} msg] $msg $::errorInfo $::errorCode +} -cleanup { + removeFile source.file +} -result {1 {} {Simulated errorInfo stuff invoked from within "source $sourcefile"} NONE} -test source-3.5 {return with special code etc.} { - makeFile { + +test source-3.5 {return with special code etc.} -setup { + set sourcefile [makeFile { set x new-x return -code error -errorinfo "Simulated errorInfo stuff" \ -errorcode {a b c} set y new-y - } source.file - list [catch {source $sourcefile} msg] $msg $errorInfo $errorCode -} {1 {} {Simulated errorInfo stuff + } source.file] +} -body { + list [catch {source $sourcefile} msg] $msg $::errorInfo $::errorCode +} -cleanup { + removeFile source.file +} -result {1 {} {Simulated errorInfo stuff invoked from within "source $sourcefile"} {a b c}} + # Test for the Macintosh specfic features of the source command -test source-4.1 {source error conditions} {macOnly} { - list [catch {source -rsrc _no_exist_} msg] $msg -} [list 1 "The resource \"_no_exist_\" could not be loaded from application."] -test source-4.2 {source error conditions} {macOnly} { - list [catch {source -rsrcid bad_id} msg] $msg -} [list 1 "expected integer but got \"bad_id\""] -test source-4.3 {source error conditions} {macOnly} { - list [catch {source -rsrc rsrcName fileName extra} msg] $msg -} {1 {wrong # args: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?"}} -test source-4.4 {source error conditions} {macOnly} { - list [catch {source non_switch rsrcName} msg] $msg -} {1 {bad argument: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?"}} -test source-4.5 {source error conditions} {macOnly} { - list [catch {source -bad_switch argument} msg] $msg -} {1 {bad argument: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?"}} -test source-5.1 {source resource files} {macOnly} { - list [catch {source -rsrc rsrcName bad_file} msg] $msg -} [list 1 "Error finding the file: \"bad_file\"."] -test source-5.2 {source resource files} {macOnly} { - makeFile {return} source.file - list [catch {source -rsrc rsrcName $sourcefile} msg] $msg -} [list 1 "Error reading the file: \"$sourcefile\"."] -test source-5.3 {source resource files} {macOnly} { - testWriteTextResource -rsrc rsrcName -file rsrc.file {set msg2 ok; return} - set result [catch {source -rsrc rsrcName rsrc.file} msg] +test source-4.1 {source error conditions} -constraints macOnly -body { + source -rsrc _no_exist_ +} -result {The resource "_no_exist_" could not be loaded from application.} \ + -returnCodes error + +test source-4.2 {source error conditions} -constraints macOnly -body { + source -rsrcid bad_id +} -returnCodes error -result {expected integer but got "bad_id"} + +test source-4.3 {source error conditions} -constraints macOnly -body { + source -rsrc rsrcName fileName extra +} -returnCodes error -result {wrong # args: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?" or "source -encoding name fileName"} + +test source-4.4 {source error conditions} -constraints macOnly -body { + source non_switch rsrcName +} -returnCodes error -result {bad argument: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?" or "source -encoding name fileName"} + +test source-4.5 {source error conditions} -constraints macOnly -body { + source -bad_switch argument +} -returnCodes error -result {bad argument: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?" or "source -encoding name fileName"} + + +testConstraint testWriteTextResource \ + [llength [info commands testWriteTextResource]] + +test source-5.1 {source resource files} -constraints macOnly -setup { + set sourcefile [makeFile {} bad_file] + removeFile bad_file +} -body { + source -rsrc rsrcName $sourcefile +} -returnCodes error -match glob -result {Error finding the file: "*bad_file".} + +test source-5.2 {source resource files} -constraints macOnly -setup { + set sourcefile [makeFile {return} source.file] +} -body { + source -rsrc rsrcName $sourcefile +} -cleanup { + removeFile source.file +} -returnCodes error -match glob \ + -result {Error reading the file: "*source.file".} + +test source-5.3 {source resource files} -constraints { + macOnly testWriteTextResource +} -setup { + set msg2 unset + set rsrcFile [makeFile {} rsrc.file] removeFile rsrc.file + testWriteTextResource -rsrc rsrcName -file $rsrc.file {set msg2 ok; return} +} -body { + set result [catch {source -rsrc rsrcName rsrc.file} msg] list $msg2 $result $msg -} [list ok 0 {}] -test source-5.4 {source resource files} {macOnly} { - catch {unset msg2} - testWriteTextResource -rsrc fileRsrcName -file rsrc.file {set msg2 ok; return} - source -rsrc fileRsrcName rsrc.file - set result [catch {source -rsrc fileRsrcName} msg] +} -cleanup { removeFile rsrc.file +} -result [list ok 0 {}] + +test source-5.4 {source resource files} -constraints { + macOnly testWriteTextResource +} -setup { + set msg2 unset + set rsrsFile [makeFile {} rsrc.file] + removeFile rsrc.file + testWriteTextResource -rsrc fileRsrcName \ + -file $rsrcFile {set msg2 ok; return} +} -body { + source -rsrc fileRsrcName $rsrcFile + set result [catch {source -rsrc fileRsrcName} msg] list $msg2 $result $msg -} [list ok 1 {The resource "fileRsrcName" could not be loaded from application.}] -test source-5.5 {source resource files} {macOnly} { - testWriteTextResource -rsrcid 200 -file rsrc.file {set msg2 hello; set msg3 bye} - set result [catch {source -rsrcid 200 rsrc.file} msg] +} -cleanup { + removeFile rsrc.file +} -result [list ok 1 {The resource "fileRsrcName" could not be loaded from application.}] + +test source-5.5 {source resource files} -constraints { + macOnly testWriteTextResource +} -setup { + set msg2 unset + set rsrcFile [makeFile {} rsrc.file] removeFile rsrc.file + testWriteTextResource -rsrcid 200 \ + -file $rsrcFile {set msg2 hello; set msg3 bye} +} -body { + set result [catch {source -rsrcid 200 $rsrcFile} msg] list $msg2 $result $msg -} [list hello 0 bye] -test source-5.6 {source resource files} {macOnly} { - testWriteTextResource -rsrcid 200 -file rsrc.file {set msg2 hello; error bad; set msg3 bye} - set result [catch {source -rsrcid 200 rsrc.file} msg] +} -cleanup { + removeFile rsrc.file +} -result [list hello 0 bye] + +test source-5.6 {source resource files} -constraints { + macOnly testWriteTextResource +} -setup { + set msg2 unset + set rsrcFile [makeFile {} rsrc.file] removeFile rsrc.file + testWriteTextResource -rsrcid 200 \ + -file $rsrcFile {set msg2 hello; error bad; set msg3 bye} +} -body { + set result [catch {source -rsrcid 200 rsrc.file} msg] list $msg2 $result $msg -} [list hello 1 bad] +} -cleanup { + removeFile rsrc.file +} -result [list hello 1 bad] + -test source-6.1 {source is binary ok} { +test source-6.1 {source is binary ok} -setup { + # Note [makeFile] writes in the system encoding. + # [source] defaults to reading in the system encoding. + set sourcefile [makeFile [list set x "a b\0c"] source.file] +} -body { set x {} - makeFile [list set x "a b\0c"] source.file source $sourcefile string length $x -} 5 -test source-6.2 {source skips everything after Ctrl-Z: Bug 2040} { +} -cleanup { + removeFile source.file +} -result 5 + +test source-6.2 {source skips everything after Ctrl-Z: Bug 2040} -setup { + set sourcefile [makeFile "set x ab\32c" source.file] +} -body { set x {} - makeFile [list set x "ab\32c"] source.file source $sourcefile string length $x -} 2 +} -cleanup { + removeFile source.file +} -result 2 + +test source-7.1 {source -encoding test} -setup { + set sourcefile [makeFile {} source.file] + removeFile source.file + set f [open $sourcefile w] + fconfigure $f -encoding utf-8 + puts $f "set symbol(square-root) \u221A; set x correct" + close $f +} -body { + set x unset + source -encoding utf-8 $sourcefile + set x +} -cleanup { + removeFile source.file +} -result correct + +test source-7.2 {source -encoding test} -setup { + # This tests for bad interactions between [source -encoding] + # and use of the Control-Z character (\u001A) as a cross-platform + # EOF character by [source]. Here we write out and the [source] a + # file that contains the byte \x1A, although not the character \u001A in + # the indicated encoding. + set sourcefile [makeFile {} source.file] + removeFile source.file + set f [open $sourcefile w] + fconfigure $f -encoding unicode + puts $f "set symbol(square-root) \u221A; set x correct" + close $f +} -body { + set x unset + source -encoding unicode $sourcefile + set x +} -cleanup { + removeFile source.file +} -result correct -# cleanup -catch {::tcltest::removeFile source.file} -::tcltest::cleanupTests +test source-7.3 {source -encoding: syntax} -body { + # Have to spell out the -encoding option + source -e utf-8 no_file +} -returnCodes 1 -match glob -result {bad option*} + +test source-7.4 {source -encoding: syntax} -setup { + set sourcefile [makeFile {} source.file] +} -body { + source -encoding no-such-encoding $sourcefile +} -cleanup { + removeFile source.file +} -returnCodes 1 -match glob -result {unknown encoding*} + +test source-7.5 {source -encoding: correct operation} -setup { + set sourcefile [makeFile {} source.file] + removeFile source.file + set f [open $sourcefile w] + fconfigure $f -encoding utf-8 + puts $f "proc \u20ac {} {return foo}" + close $f +} -body { + source -encoding utf-8 $sourcefile + \u20ac +} -cleanup { + removeFile source.file + rename \u20ac {} +} -result foo + +test source-7.6 {source -encoding: mismatch encoding error} -setup { + set sourcefile [makeFile {} source.file] + removeFile source.file + set f [open $sourcefile w] + fconfigure $f -encoding utf-8 + puts $f "proc \u20ac {} {return foo}" + close $f +} -body { + source -encoding ascii $sourcefile + \u20ac +} -cleanup { + removeFile source.file +} -returnCodes error -match glob -result {invalid command name*} + +cleanupTests +} +namespace delete ::tcl::test::source return |