diff options
| -rw-r--r-- | ChangeLog | 7 | ||||
| -rw-r--r-- | generic/tclBasic.c | 4 | ||||
| -rw-r--r-- | generic/tclCmdMZ.c | 12 | ||||
| -rw-r--r-- | generic/tclIOUtil.c | 136 | ||||
| -rw-r--r-- | generic/tclInt.h | 8 |
5 files changed, 158 insertions, 9 deletions
@@ -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); |