summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog7
-rw-r--r--generic/tclBasic.c4
-rw-r--r--generic/tclCmdMZ.c12
-rw-r--r--generic/tclIOUtil.c136
-rw-r--r--generic/tclInt.h8
5 files changed, 158 insertions, 9 deletions
diff --git a/ChangeLog b/ChangeLog
index 9203a0d..8825ec2 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2009-01-05 Donal K. Fellows <dkf@users.sf.net>
+
+ * generic/tclCmdMZ.c (TclNRSourceObjCmd): Make implementation of the
+ * generic/tclIOUtil.c (TclNREvalFile): [source] command be NRE
+ enabled so that [yield] inside a script sourced in a coroutine can
+ work. [Bug 2412068]
+
2009-01-04 Donal K. Fellows <dkf@users.sf.net>
* generic/tclCmdAH.c: Tidy up spacing and code style.
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index d58368d..5f8d9dc 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -16,7 +16,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclBasic.c,v 1.378 2008/12/17 22:07:42 nijtmans Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.379 2009/01/05 09:48:11 dkf Exp $
*/
#include "tclInt.h"
@@ -244,7 +244,7 @@ static const CmdInfo builtInCmds[] = {
{"read", Tcl_ReadObjCmd, NULL, NULL, 1},
{"seek", Tcl_SeekObjCmd, NULL, NULL, 1},
{"socket", Tcl_SocketObjCmd, NULL, NULL, 0},
- {"source", Tcl_SourceObjCmd, NULL, NULL, 0},
+ {"source", Tcl_SourceObjCmd, NULL, TclNRSourceObjCmd, 0},
{"tell", Tcl_TellObjCmd, NULL, NULL, 1},
{"time", Tcl_TimeObjCmd, NULL, NULL, 1},
{"unload", Tcl_UnloadObjCmd, NULL, NULL, 0},
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index c42370c..6025f90 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -15,7 +15,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.172 2008/12/02 19:40:41 dgp Exp $
+ * RCS: @(#) $Id: tclCmdMZ.c,v 1.173 2009/01/05 09:48:11 dkf Exp $
*/
#include "tclInt.h"
@@ -938,6 +938,16 @@ Tcl_SourceObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
+ return Tcl_NRCallObjProc(interp, TclNRSourceObjCmd, dummy, objc, objv);
+}
+
+int
+TclNRSourceObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
const char *encodingName = NULL;
Tcl_Obj *fileName;
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index 7b6a4c8..b62fee3 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.160 2008/12/02 19:40:41 dgp Exp $
+ * RCS: @(#) $Id: tclIOUtil.c,v 1.161 2009/01/05 09:48:11 dkf Exp $
*/
#include "tclInt.h"
@@ -30,6 +30,8 @@
* Prototypes for functions defined later in this file.
*/
+static int EvalFileCallback(ClientData data[],
+ Tcl_Interp *interp, int result);
static FilesystemRecord*FsGetFirstFilesystem(void);
static void FsThrExitProc(ClientData cd);
static Tcl_Obj * FsListMounts(Tcl_Obj *pathPtr, const char *pattern);
@@ -37,7 +39,6 @@ static void FsAddMountsToGlobResult(Tcl_Obj *resultPtr,
Tcl_Obj *pathPtr, const char *pattern,
Tcl_GlobTypeData *types);
static void FsUpdateCwd(Tcl_Obj *cwdObj, ClientData clientData);
-
#ifdef TCL_THREADS
static void FsRecacheFilesystemList(void);
#endif
@@ -1644,10 +1645,11 @@ TclGetOpenModeEx(
/*
*----------------------------------------------------------------------
*
- * Tcl_FSEvalFile, Tcl_FSEvalFileEx --
+ * Tcl_FSEvalFile, Tcl_FSEvalFileEx, TclNREvalFile --
*
* Read in a file and process the entire file as one gigantic Tcl
* command. Tcl_FSEvalFile is Tcl_FSEvalFileEx without encoding argument.
+ * TclNREvalFile is an NRE-enabled version of Tcl_FSEvalFileEx.
*
* Results:
* A standard Tcl result, which is either the result of executing the
@@ -1782,6 +1784,134 @@ Tcl_FSEvalFileEx(
Tcl_DecrRefCount(objPtr);
return result;
}
+
+int
+TclNREvalFile(
+ 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) /* If non-NULL, then use this encoding for the
+ * file. NULL means use the system encoding. */
+{
+ int length;
+ Tcl_StatBuf statBuf;
+ Tcl_Obj *oldScriptFile, *objPtr;
+ Interp *iPtr;
+ char *string;
+ Tcl_Channel chan;
+
+ if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) {
+ return TCL_ERROR;
+ }
+
+ if (Tcl_FSStat(pathPtr, &statBuf) == -1) {
+ Tcl_SetErrno(errno);
+ Tcl_AppendResult(interp, "couldn't read file \"",
+ Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL);
+ return TCL_ERROR;
+ }
+ chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644);
+ if (chan == NULL) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "couldn't read file \"",
+ Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * The eofchar is \32 (^Z). This is the usual on Windows, but we effect
+ * this cross-platform to allow for scripted documents. [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 != NULL) {
+ if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName)
+ != TCL_OK) {
+ Tcl_Close(interp,chan);
+ return TCL_ERROR;
+ }
+ }
+
+ objPtr = Tcl_NewObj();
+ Tcl_IncrRefCount(objPtr);
+ if (Tcl_ReadChars(chan, objPtr, -1, 0) < 0) {
+ Tcl_Close(interp, chan);
+ Tcl_AppendResult(interp, "couldn't read file \"",
+ Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL);
+ Tcl_DecrRefCount(objPtr);
+ return TCL_ERROR;
+ }
+
+ if (Tcl_Close(interp, chan) != TCL_OK) {
+ Tcl_DecrRefCount(objPtr);
+ return TCL_ERROR;
+ }
+
+ iPtr = (Interp *) interp;
+ oldScriptFile = iPtr->scriptFile;
+ iPtr->scriptFile = pathPtr;
+ Tcl_IncrRefCount(iPtr->scriptFile);
+ string = Tcl_GetStringFromObj(objPtr, &length);
+
+ /*
+ * TIP #280: Force the evaluator to open a frame for a sourced file.
+ */
+
+ iPtr->evalFlags |= TCL_EVAL_FILE;
+ TclNRAddCallback(interp, EvalFileCallback, oldScriptFile, pathPtr, objPtr,
+ NULL);
+ return TclNREvalObjEx(interp, objPtr, 0, NULL, INT_MIN);
+}
+
+static int
+EvalFileCallback(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Obj *oldScriptFile = data[0];
+ Tcl_Obj *pathPtr = data[1];
+ Tcl_Obj *objPtr = data[2];
+
+ /*
+ * Now we have to be careful; the script may have changed the
+ * iPtr->scriptFile value, so we must reset it without assuming it still
+ * points to 'pathPtr'.
+ */
+
+ if (iPtr->scriptFile != NULL) {
+ Tcl_DecrRefCount(iPtr->scriptFile);
+ }
+ iPtr->scriptFile = oldScriptFile;
+
+ if (result == TCL_RETURN) {
+ result = TclUpdateReturnInfo(iPtr);
+ } else if (result == TCL_ERROR) {
+ /*
+ * Record information telling where the error occurred.
+ */
+
+ int length;
+ const char *pathString = Tcl_GetStringFromObj(pathPtr, &length);
+ int limit = 150;
+ int overflow = (length > limit);
+
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (file \"%.*s%s\" line %d)",
+ (overflow ? limit : length), pathString,
+ (overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
+ }
+
+ Tcl_DecrRefCount(objPtr);
+ return result;
+}
/*
*----------------------------------------------------------------------
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 7e3d1e4..7551956 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -15,7 +15,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.h,v 1.410 2008/12/11 01:21:52 dkf Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.411 2009/01/05 09:48:11 dkf Exp $
*/
#ifndef _TCLINT
@@ -2565,6 +2565,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRCatchObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRForObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRForeachCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRIfObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRSourceObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRWhileObjCmd;
MODULE_SCOPE Tcl_NRPostProc TclNRForIterCallback;
@@ -2578,7 +2579,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd;
*----------------------------------------------------------------
*/
-MODULE_SCOPE int TclNREvalCmd(Tcl_Interp * interp, Tcl_Obj * objPtr,
+MODULE_SCOPE int TclNREvalCmd(Tcl_Interp *interp, Tcl_Obj *objPtr,
int flags);
MODULE_SCOPE void TclAdvanceLines(int *line, const char *start,
const char *end);
@@ -2644,6 +2645,8 @@ MODULE_SCOPE double TclFloor(mp_int *a);
MODULE_SCOPE void TclFormatNaN(double value, char *buffer);
MODULE_SCOPE int TclFSFileAttrIndex(Tcl_Obj *pathPtr,
const char *attributeName, int *indexPtr);
+MODULE_SCOPE int TclNREvalFile(Tcl_Interp *interp, Tcl_Obj *pathPtr,
+ const char *encodingName);
MODULE_SCOPE void TclFSUnloadTempFile(Tcl_LoadHandle loadHandle);
MODULE_SCOPE int * TclGetAsyncReadyPtr(void);
MODULE_SCOPE Tcl_Obj * TclGetBgErrorHandler(Tcl_Interp *interp);
@@ -2848,7 +2851,6 @@ MODULE_SCOPE double TclpWideClicksToNanoseconds(Tcl_WideInt clicks);
#endif
MODULE_SCOPE Tcl_Obj * TclDisassembleByteCodeObj(Tcl_Obj *objPtr);
MODULE_SCOPE int TclZlibInit(Tcl_Interp *interp);
-
MODULE_SCOPE void * TclpThreadCreateKey(void);
MODULE_SCOPE void TclpThreadDeleteKey(void *keyPtr);
MODULE_SCOPE void TclpThreadSetMasterTSD(void *tsdKeyPtr, void *ptr);