diff options
Diffstat (limited to 'generic/tclCmdAH.c')
| -rw-r--r-- | generic/tclCmdAH.c | 159 |
1 files changed, 111 insertions, 48 deletions
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 5ca5cf8..d90a747 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -32,6 +32,9 @@ struct ForeachState { int *argcList; /* Array of value list sizes. */ Tcl_Obj ***argvList; /* Array of value lists. */ Tcl_Obj **aCopyList; /* Copies of value list arguments. */ + Tcl_Obj *resultList; /* List of result values from the loop body, + * or NULL if we're not collecting them + * ([lmap] vs [foreach]). */ }; /* @@ -52,6 +55,8 @@ static int GetStatBuf(Tcl_Interp *interp, Tcl_Obj *pathPtr, static const char * GetTypeFromMode(int mode); static int StoreStatData(Tcl_Interp *interp, Tcl_Obj *varName, Tcl_StatBuf *statPtr); +static inline int EachloopCmd(Tcl_Interp *interp, int collect, + int objc, Tcl_Obj *const objv[]); static Tcl_NRPostProc CatchObjCmdCallback; static Tcl_NRPostProc ExprCallback; static Tcl_NRPostProc ForSetupCallback; @@ -189,8 +194,7 @@ Tcl_CaseObjCmd( for (i = 0; i < caseObjc; i += 2) { int patObjc, j; const char **patObjv; - const char *pat; - unsigned char *p; + const char *pat, *p; if (i == caseObjc-1) { Tcl_ResetResult(interp); @@ -205,8 +209,8 @@ Tcl_CaseObjCmd( */ pat = TclGetString(caseObjv[i]); - for (p = (unsigned char *) pat; *p != '\0'; p++) { - if (isspace(*p) || (*p == '\\')) { /* INTL: ISO space, UCHAR */ + for (p = pat; *p != '\0'; p++) { + if (TclIsSpaceProc(*p) || (*p == '\\')) { break; } } @@ -356,7 +360,8 @@ CatchObjCmdCallback( if (NULL == Tcl_ObjSetVar2(interp, optionVarNamePtr, NULL, options, TCL_LEAVE_ERR_MSG)) { - Tcl_DecrRefCount(options); + /* Do not decrRefCount 'options', it was already done by + * Tcl_ObjSetVar2 */ return TCL_ERROR; } } @@ -944,40 +949,40 @@ TclInitFileCmd( */ static const EnsembleImplMap initMap[] = { - {"atime", FileAttrAccessTimeCmd, NULL, NULL, NULL, 0}, - {"attributes", TclFileAttrsCmd, NULL, NULL, NULL, 0}, - {"channels", TclChannelNamesCmd, NULL, NULL, NULL, 0}, - {"copy", TclFileCopyCmd, NULL, NULL, NULL, 0}, - {"delete", TclFileDeleteCmd, NULL, NULL, NULL, 0}, - {"dirname", PathDirNameCmd, NULL, NULL, NULL, 0}, - {"executable", FileAttrIsExecutableCmd, NULL, NULL, NULL, 0}, - {"exists", FileAttrIsExistingCmd, NULL, NULL, NULL, 0}, - {"extension", PathExtensionCmd, NULL, NULL, NULL, 0}, - {"isdirectory", FileAttrIsDirectoryCmd, NULL, NULL, NULL, 0}, - {"isfile", FileAttrIsFileCmd, NULL, NULL, NULL, 0}, - {"join", PathJoinCmd, NULL, NULL, NULL, 0}, - {"link", TclFileLinkCmd, NULL, NULL, NULL, 0}, - {"lstat", FileAttrLinkStatCmd, NULL, NULL, NULL, 0}, - {"mtime", FileAttrModifyTimeCmd, NULL, NULL, NULL, 0}, - {"mkdir", TclFileMakeDirsCmd, NULL, NULL, NULL, 0}, - {"nativename", PathNativeNameCmd, NULL, NULL, NULL, 0}, - {"normalize", PathNormalizeCmd, NULL, NULL, NULL, 0}, - {"owned", FileAttrIsOwnedCmd, NULL, NULL, NULL, 0}, - {"pathtype", PathTypeCmd, NULL, NULL, NULL, 0}, - {"readable", FileAttrIsReadableCmd, NULL, NULL, NULL, 0}, - {"readlink", TclFileReadLinkCmd, NULL, NULL, NULL, 0}, - {"rename", TclFileRenameCmd, NULL, NULL, NULL, 0}, - {"rootname", PathRootNameCmd, NULL, NULL, NULL, 0}, - {"separator", FilesystemSeparatorCmd, NULL, NULL, NULL, 0}, - {"size", FileAttrSizeCmd, NULL, NULL, NULL, 0}, - {"split", PathSplitCmd, NULL, NULL, NULL, 0}, - {"stat", FileAttrStatCmd, NULL, NULL, NULL, 0}, - {"system", PathFilesystemCmd, NULL, NULL, NULL, 0}, - {"tail", PathTailCmd, NULL, NULL, NULL, 0}, - {"tempfile", TclFileTemporaryCmd, NULL, NULL, NULL, 0}, - {"type", FileAttrTypeCmd, NULL, NULL, NULL, 0}, - {"volumes", FilesystemVolumesCmd, NULL, NULL, NULL, 0}, - {"writable", FileAttrIsWritableCmd, NULL, NULL, NULL, 0}, + {"atime", FileAttrAccessTimeCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, + {"attributes", TclFileAttrsCmd, NULL, NULL, NULL, 0}, + {"channels", TclChannelNamesCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"copy", TclFileCopyCmd, NULL, NULL, NULL, 0}, + {"delete", TclFileDeleteCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0}, + {"dirname", PathDirNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"executable", FileAttrIsExecutableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"exists", FileAttrIsExistingCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"extension", PathExtensionCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"isdirectory", FileAttrIsDirectoryCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"isfile", FileAttrIsFileCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"join", PathJoinCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0}, + {"link", TclFileLinkCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0}, + {"lstat", FileAttrLinkStatCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, + {"mtime", FileAttrModifyTimeCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, + {"mkdir", TclFileMakeDirsCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0}, + {"nativename", PathNativeNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"normalize", PathNormalizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"owned", FileAttrIsOwnedCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"pathtype", PathTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"readable", FileAttrIsReadableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"readlink", TclFileReadLinkCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"rename", TclFileRenameCmd, NULL, NULL, NULL, 0}, + {"rootname", PathRootNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"separator", FilesystemSeparatorCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"size", FileAttrSizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"split", PathSplitCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"stat", FileAttrStatCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, + {"system", PathFilesystemCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"tail", PathTailCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"tempfile", TclFileTemporaryCmd, TclCompileBasic0To2ArgCmd, NULL, NULL, 0}, + {"type", FileAttrTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"volumes", FilesystemVolumesCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, + {"writable", FileAttrIsWritableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {NULL, NULL, NULL, NULL, NULL, 0} }; return TclMakeEnsemble(interp, "file", initMap); @@ -1585,7 +1590,7 @@ FileAttrIsOwnedCmd( * test for equivalence to the current user. */ -#if defined(__WIN32__) || defined(__CYGWIN__) +#if defined(_WIN32) || defined(__CYGWIN__) value = 1; #else value = (geteuid() == buf.st_uid); @@ -2565,7 +2570,7 @@ ForPostNextCallback( /* *---------------------------------------------------------------------- * - * Tcl_ForeachObjCmd, TclNRForeachCmd -- + * Tcl_ForeachObjCmd, TclNRForeachCmd, EachloopCmd -- * * This object-based procedure is invoked to process the "foreach" Tcl * command. See the user documentation for details on what it does. @@ -2597,6 +2602,38 @@ TclNRForeachCmd( int objc, Tcl_Obj *const objv[]) { + return EachloopCmd(interp, TCL_EACH_KEEP_NONE, objc, objv); +} + +int +Tcl_LmapObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + return Tcl_NRCallObjProc(interp, TclNRLmapCmd, dummy, objc, objv); +} + +int +TclNRLmapCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + return EachloopCmd(interp, TCL_EACH_COLLECT, objc, objv); +} + +static inline int +EachloopCmd( + Tcl_Interp *interp, /* Our context for variables and script + * evaluation. */ + int collect, /* Select collecting or accumulating mode + * (TCL_EACH_*) */ + int objc, /* The arguments being passed in... */ + Tcl_Obj *const objv[]) +{ int numLists = (objc-2) / 2; register struct ForeachState *statePtr; int i, j, result; @@ -2640,6 +2677,12 @@ TclNRForeachCmd( statePtr->bodyPtr = objv[objc - 1]; statePtr->bodyIdx = objc - 1; + if (collect == TCL_EACH_COLLECT) { + statePtr->resultList = Tcl_NewListObj(0, NULL); + } else { + statePtr->resultList = NULL; + } + /* * Break up the value lists and variable lists into elements. */ @@ -2653,9 +2696,11 @@ TclNRForeachCmd( TclListObjGetElements(NULL, statePtr->vCopyList[i], &statePtr->varcList[i], &statePtr->varvList[i]); if (statePtr->varcList[i] < 1) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "foreach varlist is empty", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FOREACH", + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s varlist is empty", + (statePtr->resultList != NULL ? "lmap" : "foreach"))); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", + (statePtr->resultList != NULL ? "LMAP" : "FOREACH"), "NEEDVARS", NULL); result = TCL_ERROR; goto done; @@ -2725,14 +2770,21 @@ ForeachLoopStep( switch (result) { case TCL_CONTINUE: result = TCL_OK; + break; case TCL_OK: + if (statePtr->resultList != NULL) { + Tcl_ListObjAppendElement(interp, statePtr->resultList, + Tcl_GetObjResult(interp)); + } break; case TCL_BREAK: result = TCL_OK; - goto done; + goto finish; case TCL_ERROR: Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (\"foreach\" body line %d)", Tcl_GetErrorLine(interp))); + "\n (\"%s\" body line %d)", + (statePtr->resultList != NULL ? "lmap" : "foreach"), + Tcl_GetErrorLine(interp))); default: goto done; } @@ -2757,7 +2809,14 @@ ForeachLoopStep( * We're done. Tidy up our work space and finish off. */ - Tcl_ResetResult(interp); + finish: + if (statePtr->resultList == NULL) { + Tcl_ResetResult(interp); + } else { + Tcl_SetObjResult(interp, statePtr->resultList); + statePtr->resultList = NULL; /* Don't clean it up */ + } + done: ForeachCleanup(interp, statePtr); return result; @@ -2790,7 +2849,8 @@ ForeachAssignments( if (varValuePtr == NULL) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (setting foreach loop variable \"%s\")", + "\n (setting %s loop variable \"%s\")", + (statePtr->resultList != NULL ? "lmap" : "foreach"), TclGetString(statePtr->varvList[i][v]))); return TCL_ERROR; } @@ -2819,6 +2879,9 @@ ForeachCleanup( TclDecrRefCount(statePtr->aCopyList[i]); } } + if (statePtr->resultList != NULL) { + TclDecrRefCount(statePtr->resultList); + } TclStackFree(interp, statePtr); } |