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