Make [source] NRE-aware to enable [yield]. [Bug 2412068]

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);