Attachment "tip137.patch" to
ticket [742683ffff]
added by
dgp
2003-09-06 04:29:30.
Index: doc/FileSystem.3
===================================================================
RCS file: /cvsroot/tcl/tcl/doc/FileSystem.3,v
retrieving revision 1.34
diff -u -r1.34 FileSystem.3
--- doc/FileSystem.3 28 Jul 2003 12:16:02 -0000 1.34
+++ doc/FileSystem.3 5 Sep 2003 21:23:17 -0000
@@ -28,10 +28,10 @@
\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 @@
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_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 @@
.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 @@
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
Index: doc/source.n
===================================================================
RCS file: /cvsroot/tcl/tcl/doc/source.n,v
retrieving revision 1.5
diff -u -r1.5 source.n
--- doc/source.n 7 Sep 2000 14:27:51 -0000 1.5
+++ doc/source.n 5 Sep 2003 21:23:17 -0000
@@ -17,6 +17,10 @@
.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 @@
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 @@
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 @@
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
Index: doc/tclsh.1
===================================================================
RCS file: /cvsroot/tcl/tcl/doc/tclsh.1,v
retrieving revision 1.8
diff -u -r1.8 tclsh.1
--- doc/tclsh.1 13 Feb 2003 22:03:34 -0000 1.8
+++ doc/tclsh.1 5 Sep 2003 21:23:17 -0000
@@ -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 @@
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 @@
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 @@
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 @@
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
Index: generic/tcl.decls
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tcl.decls,v
retrieving revision 1.99
diff -u -r1.99 tcl.decls
--- generic/tcl.decls 25 Aug 2003 20:06:04 -0000 1.99
+++ generic/tcl.decls 5 Sep 2003 21:23:17 -0000
@@ -1849,6 +1849,11 @@
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
Index: generic/tclCmdMZ.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCmdMZ.c,v
retrieving revision 1.93
diff -u -r1.93 tclCmdMZ.c
--- generic/tclCmdMZ.c 4 Jul 2003 10:30:27 -0000 1.93
+++ generic/tclCmdMZ.c 5 Sep 2003 21:23:19 -0000
@@ -1004,12 +1004,26 @@
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);
}
/*
Index: generic/tclDecls.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclDecls.h,v
retrieving revision 1.98
diff -u -r1.98 tclDecls.h
--- generic/tclDecls.h 25 Aug 2003 21:05:15 -0000 1.98
+++ generic/tclDecls.h 5 Sep 2003 21:23:22 -0000
@@ -3211,6 +3211,13 @@
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 @@
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
@@ -5899,6 +5907,10 @@
#ifndef Tcl_GetCommandFullName
#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) */
Index: generic/tclIOUtil.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclIOUtil.c,v
retrieving revision 1.82
diff -u -r1.82 tclIOUtil.c
--- generic/tclIOUtil.c 23 Aug 2003 12:16:49 -0000 1.82
+++ generic/tclIOUtil.c 5 Sep 2003 21:23:24 -0000
@@ -1363,10 +1363,20 @@
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 @@
*/
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 @@
* [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 \"",
Index: generic/tclInt.decls
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclInt.decls,v
retrieving revision 1.62
diff -u -r1.62 tclInt.decls
--- generic/tclInt.decls 26 Jun 2003 08:43:15 -0000 1.62
+++ generic/tclInt.decls 5 Sep 2003 21:23:25 -0000
@@ -719,6 +719,12 @@
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
Index: generic/tclIntDecls.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclIntDecls.h,v
retrieving revision 1.52
diff -u -r1.52 tclIntDecls.h
--- generic/tclIntDecls.h 25 Aug 2003 21:05:15 -0000 1.52
+++ generic/tclIntDecls.h 5 Sep 2003 21:23:25 -0000
@@ -937,6 +937,18 @@
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 @@
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
@@ -1769,6 +1783,14 @@
#ifndef TclVarErrMsg
#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) */
Index: generic/tclMain.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclMain.c,v
retrieving revision 1.20
diff -u -r1.20 tclMain.c
--- generic/tclMain.c 29 May 2002 22:59:33 -0000 1.20
+++ generic/tclMain.c 5 Sep 2003 21:23:26 -0000
@@ -32,6 +32,7 @@
#endif
static Tcl_Obj *tclStartupScriptPath = NULL;
+static Tcl_Obj *tclStartupScriptEncoding = NULL;
static Tcl_MainLoopProc *mainLoopProc = NULL;
@@ -73,32 +74,102 @@
/*
*----------------------------------------------------------------------
*
- * 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 @@
*/
Tcl_Obj *TclGetStartupScriptPath()
{
- return tclStartupScriptPath;
+ return Tcl_GetStartupScript(NULL);
}
-
/*
*----------------------------------------------------------------------
*
@@ -142,8 +212,8 @@
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 @@
*/
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 @@
* 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_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_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 @@
*/
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 @@
/*
* 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_DeleteInterp(interp);
}
}
- TclSetStartupScriptPath(NULL);
+ Tcl_SetStartupScript(NULL, NULL);
/*
* If we get here, the master interp has been deleted. Allow
Index: generic/tclStubInit.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclStubInit.c,v
retrieving revision 1.87
diff -u -r1.87 tclStubInit.c
--- generic/tclStubInit.c 25 Aug 2003 20:06:37 -0000 1.87
+++ generic/tclStubInit.c 5 Sep 2003 21:23:26 -0000
@@ -272,6 +272,8 @@
TclCallVarTraces, /* 175 */
TclCleanupVar, /* 176 */
TclVarErrMsg, /* 177 */
+ Tcl_SetStartupScript, /* 178 */
+ Tcl_GetStartupScript, /* 179 */
};
TclIntPlatStubs tclIntPlatStubs = {
@@ -960,6 +962,7 @@
Tcl_FindCommand, /* 515 */
Tcl_GetCommandFromObj, /* 516 */
Tcl_GetCommandFullName, /* 517 */
+ Tcl_FSEvalFileEx, /* 518 */
};
/* !END!: Do not edit above this line. */
Index: mac/tclMacResource.c
===================================================================
RCS file: /cvsroot/tcl/tcl/mac/tclMacResource.c,v
retrieving revision 1.15
diff -u -r1.15 tclMacResource.c
--- mac/tclMacResource.c 14 May 2003 19:21:24 -0000 1.15
+++ mac/tclMacResource.c 5 Sep 2003 21:23:28 -0000
@@ -946,6 +946,7 @@
char *fileName = NULL, *rsrcName = NULL;
long rsrcID = -1;
char *string;
+ char *encodingName = NULL;
int length;
if (objc < 2 || objc > 4) {
@@ -968,6 +969,10 @@
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 @@
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;
}
Index: tests/cmdMZ.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/cmdMZ.test,v
retrieving revision 1.17
diff -u -r1.17 cmdMZ.test
--- tests/cmdMZ.test 29 Aug 2003 17:43:24 -0000 1.17
+++ tests/cmdMZ.test 5 Sep 2003 21:23:28 -0000
@@ -187,6 +187,7 @@
# 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.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
Index: tests/main.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/main.test,v
retrieving revision 1.13
diff -u -r1.13 main.test
--- tests/main.test 16 Feb 2003 01:36:32 -0000 1.13
+++ tests/main.test 5 Sep 2003 21:23:28 -0000
@@ -139,6 +139,72 @@
} -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 {
Index: tests/source.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/source.test,v
retrieving revision 1.8
diff -u -r1.8 source.test
--- tests/source.test 5 Jul 2002 10:38:43 -0000 1.8
+++ tests/source.test 5 Sep 2003 21:23:28 -0000
@@ -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 $
-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
- source $sourcefile
-} result
-test source-1.3 {source command} {
- set y {\ }
+} -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
+} -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}}}
+"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-3.1 {return in middle of source file} {
- makeFile {
+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
