diff options
| -rw-r--r-- | ChangeLog | 17 | ||||
| -rw-r--r-- | generic/tclBasic.c | 12 | ||||
| -rw-r--r-- | generic/tclCmdAH.c | 1785 | ||||
| -rw-r--r-- | generic/tclEnsemble.c | 43 | ||||
| -rw-r--r-- | generic/tclFCmd.c | 443 | ||||
| -rw-r--r-- | generic/tclIOCmd.c | 37 | ||||
| -rw-r--r-- | generic/tclInt.h | 28 | ||||
| -rw-r--r-- | tests/cmdAH.test | 24 | ||||
| -rw-r--r-- | tests/fCmd.test | 8 | ||||
| -rw-r--r-- | tests/fileSystem.test | 4 | ||||
| -rw-r--r-- | tests/interp.test | 328 |
11 files changed, 1799 insertions, 930 deletions
@@ -1,5 +1,22 @@ 2010-12-09 Donal K. Fellows <dkf@users.sf.net> + * generic/tclCmdAH.c (TclInitFileCmd, TclMakeFileCommandSafe, ...): + Break up [file] into an ensemble. Note that the ensemble is safe in + itself, but the majority of its subcommands are not. + * generic/tclFCmd.c (FileCopyRename,TclFileDeleteCmd,TclFileAttrsCmd) + (TclFileMakeDirsCmd): Adjust these subcommand implementations to work + inside an ensemble. + (TclFileLinkCmd, TclFileReadLinkCmd, TclFileTemporaryCmd): Move these + subcommand implementations from tclCmdAH.c, where they didn't really + belong. + * generic/tclIOCmd.c (TclChannelNamesCmd): Move to more appropriate + source file. + * generic/tclEnsemble.c (TclMakeEnsemble): Start of code to make + partially-safe ensembles. Currently does not function as expected due + to various shortcomings in how safe interpreters are constructed. + * tests/cmdAH.test, tests/fCmd.test, tests/interp.test: Test updates + to take into account systematization of error messages. + * tests/append.test, tests/appendComp.test: Clean up tests so that they don't leave things in the global environment (detected when doing -singleproc testing). diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 22daf78..d863347 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.471 2010/12/01 09:58:52 nijtmans Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.472 2010/12/09 15:09:07 dkf Exp $ */ #include "tclInt.h" @@ -276,7 +276,6 @@ static const CmdInfo builtInCmds[] = { {"fblocked", Tcl_FblockedObjCmd, NULL, NULL, 1}, {"fconfigure", Tcl_FconfigureObjCmd, NULL, NULL, 0}, {"fcopy", Tcl_FcopyObjCmd, NULL, NULL, 1}, - {"file", Tcl_FileObjCmd, NULL, NULL, 0}, {"fileevent", Tcl_FileEventObjCmd, NULL, NULL, 1}, {"flush", Tcl_FlushObjCmd, NULL, NULL, 1}, {"gets", Tcl_GetsObjCmd, NULL, NULL, 1}, @@ -783,15 +782,17 @@ Tcl_CreateInterp(void) } /* - * Create the "array", "binary", "chan", "dict", "info" and "string" - * ensembles. Note that all these commands (and their subcommands that are - * not present in the global namespace) are wholly safe. + * Create the "array", "binary", "chan", "dict", "file", "info" and + * "string" ensembles. Note that all these commands (and their subcommands + * that are not present in the global namespace) are wholly safe *except* + * for "file". */ TclInitArrayCmd(interp); TclInitBinaryCmd(interp); TclInitChanCmd(interp); TclInitDictCmd(interp); + TclInitFileCmd(interp); TclInitInfoCmd(interp); TclInitStringCmd(interp); TclInitPrefixCmd(interp); @@ -1007,6 +1008,7 @@ TclHideUnsafeCommands( Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name); } } + TclMakeFileCommandSafe(interp); /* Ugh! */ return TCL_OK; } diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index eac0cea..4326276 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -10,12 +10,11 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdAH.c,v 1.127 2010/09/23 18:08:35 dgp Exp $ + * RCS: @(#) $Id: tclCmdAH.c,v 1.128 2010/12/09 15:09:07 dkf Exp $ */ #include "tclInt.h" #include <locale.h> -#include "tclFileSystem.h" /* * The state structure used by [foreach]. Note that the actual structure has @@ -46,8 +45,6 @@ static int CheckAccess(Tcl_Interp *interp, Tcl_Obj *pathPtr, static int EncodingDirsObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int FileTempfileCmd(Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); static inline int ForeachAssignments(Tcl_Interp *interp, struct ForeachState *statePtr); static inline void ForeachCleanup(Tcl_Interp *interp, @@ -65,6 +62,32 @@ static Tcl_NRPostProc ForNextCallback; static Tcl_NRPostProc ForPostNextCallback; static Tcl_NRPostProc ForeachLoopStep; static Tcl_NRPostProc EvalCmdErrMsg; + +static Tcl_ObjCmdProc FileAttrAccessTimeCmd; +static Tcl_ObjCmdProc FileAttrIsDirectoryCmd; +static Tcl_ObjCmdProc FileAttrIsExecutableCmd; +static Tcl_ObjCmdProc FileAttrIsExistingCmd; +static Tcl_ObjCmdProc FileAttrIsFileCmd; +static Tcl_ObjCmdProc FileAttrIsOwnedCmd; +static Tcl_ObjCmdProc FileAttrIsReadableCmd; +static Tcl_ObjCmdProc FileAttrIsWritableCmd; +static Tcl_ObjCmdProc FileAttrLinkStatCmd; +static Tcl_ObjCmdProc FileAttrModifyTimeCmd; +static Tcl_ObjCmdProc FileAttrSizeCmd; +static Tcl_ObjCmdProc FileAttrStatCmd; +static Tcl_ObjCmdProc FileAttrTypeCmd; +static Tcl_ObjCmdProc FilesystemSeparatorCmd; +static Tcl_ObjCmdProc FilesystemVolumesCmd; +static Tcl_ObjCmdProc PathDirNameCmd; +static Tcl_ObjCmdProc PathExtensionCmd; +static Tcl_ObjCmdProc PathFilesystemCmd; +static Tcl_ObjCmdProc PathJoinCmd; +static Tcl_ObjCmdProc PathNativeNameCmd; +static Tcl_ObjCmdProc PathNormalizeCmd; +static Tcl_ObjCmdProc PathRootNameCmd; +static Tcl_ObjCmdProc PathSplitCmd; +static Tcl_ObjCmdProc PathTailCmd; +static Tcl_ObjCmdProc PathTypeCmd; /* *---------------------------------------------------------------------- @@ -882,13 +905,14 @@ ExprCallback( /* *---------------------------------------------------------------------- * - * Tcl_FileObjCmd -- + * TclInitFileCmd -- * - * This procedure is invoked to process the "file" Tcl command. See the - * user documentation for details on what it does. PLEASE NOTE THAT THIS - * FAILS WITH FILENAMES AND PATHS WITH EMBEDDED NULLS. With the - * object-based Tcl_FS APIs, the above NOTE may no longer be true. In any - * case this assertion should be tested. + * This function builds the "file" Tcl command ensemble. See the user + * documentation for details on what that ensemble does. + * + * PLEASE NOTE THAT THIS FAILS WITH FILENAMES AND PATHS WITH EMBEDDED + * NULLS. With the object-based Tcl_FS APIs, the above NOTE may no longer + * be true. In any case this assertion should be tested. * * Results: * A standard Tcl result. @@ -899,570 +923,1160 @@ ExprCallback( *---------------------------------------------------------------------- */ - /* ARGSUSED */ -int -Tcl_FileObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +Tcl_Command +TclInitFileCmd( + Tcl_Interp *interp) { - int index, value; - Tcl_StatBuf buf; - struct utimbuf tval; - /* - * This list of constants should match the fileOption string array below. + * Note that most subcommands are unsafe because either they manipulate + * the native filesystem or because they reveal information about the + * native filesystem. */ - static const char *const fileOptions[] = { - "atime", "attributes", "channels", "copy", - "delete", - "dirname", "executable", "exists", "extension", - "isdirectory", "isfile", "join", "link", - "lstat", "mtime", "mkdir", "nativename", - "normalize", "owned", - "pathtype", "readable", "readlink", "rename", - "rootname", "separator", "size", "split", - "stat", "system", "tail", "tempfile", - "type", "volumes", "writable", - NULL + static const EnsembleImplMap initMap[] = { + {"atime", FileAttrAccessTimeCmd}, + {"attributes", TclFileAttrsCmd}, + {"channels", TclChannelNamesCmd}, + {"copy", TclFileCopyCmd}, + {"delete", TclFileDeleteCmd}, + {"dirname", PathDirNameCmd}, + {"executable", FileAttrIsExecutableCmd}, + {"exists", FileAttrIsExistingCmd}, + {"extension", PathExtensionCmd}, + {"isdirectory", FileAttrIsDirectoryCmd}, + {"isfile", FileAttrIsFileCmd}, + {"join", PathJoinCmd}, + {"link", TclFileLinkCmd}, + {"lstat", FileAttrLinkStatCmd}, + {"mtime", FileAttrModifyTimeCmd}, + {"mkdir", TclFileMakeDirsCmd}, + {"nativename", PathNativeNameCmd}, + {"normalize", PathNormalizeCmd}, + {"owned", FileAttrIsOwnedCmd}, + {"pathtype", PathTypeCmd}, + {"readable", FileAttrIsReadableCmd}, + {"readlink", TclFileReadLinkCmd}, + {"rename", TclFileRenameCmd}, + {"rootname", PathRootNameCmd}, + {"separator", FilesystemSeparatorCmd}, + {"size", FileAttrSizeCmd}, + {"split", PathSplitCmd}, + {"stat", FileAttrStatCmd}, + {"system", PathFilesystemCmd}, + {"tail", PathTailCmd}, + {"tempfile", TclFileTemporaryCmd}, + {"type", FileAttrTypeCmd}, + {"volumes", FilesystemVolumesCmd}, + {"writable", FileAttrIsWritableCmd}, + {NULL} }; - enum options { - FCMD_ATIME, FCMD_ATTRIBUTES, FCMD_CHANNELS, FCMD_COPY, - FCMD_DELETE, - FCMD_DIRNAME, FCMD_EXECUTABLE, FCMD_EXISTS, FCMD_EXTENSION, - FCMD_ISDIRECTORY, FCMD_ISFILE, FCMD_JOIN, FCMD_LINK, - FCMD_LSTAT, FCMD_MTIME, FCMD_MKDIR, FCMD_NATIVENAME, - FCMD_NORMALIZE, FCMD_OWNED, - FCMD_PATHTYPE, FCMD_READABLE, FCMD_READLINK, FCMD_RENAME, - FCMD_ROOTNAME, FCMD_SEPARATOR, FCMD_SIZE, FCMD_SPLIT, - FCMD_STAT, FCMD_SYSTEM, FCMD_TAIL, FCMD_TEMPFILE, - FCMD_TYPE, FCMD_VOLUMES, FCMD_WRITABLE + return TclMakeEnsemble(interp, "file", initMap); +} + +/* + *---------------------------------------------------------------------- + * + * TclMakeFileCommandSafe -- + * + * This function hides the unsafe subcommands of the "file" Tcl command + * ensemble. It must only be called from TclHideUnsafeCommands. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Adds commands to the table of hidden commands. + * + *---------------------------------------------------------------------- + */ + +int +TclMakeFileCommandSafe( + Tcl_Interp *interp) +{ + static const struct { + const char *cmdName; + int unsafe; + } unsafeInfo[] = { + {"atime", 1}, + {"attributes", 1}, + {"channels", 0}, + {"copy", 1}, + {"delete", 1}, + {"dirname", 1}, + {"executable", 1}, + {"exists", 1}, + {"extension", 1}, + {"isdirectory", 1}, + {"isfile", 1}, + {"join", 0}, + {"link", 1}, + {"lstat", 1}, + {"mtime", 1}, + {"mkdir", 1}, + {"nativename", 1}, + {"normalize", 1}, + {"owned", 1}, + {"pathtype", 0}, + {"readable", 1}, + {"readlink", 1}, + {"rename", 1}, + {"rootname", 1}, + {"separator", 0}, + {"size", 1}, + {"split", 0}, + {"stat", 1}, + {"system", 0}, + {"tail", 1}, + {"tempfile", 1}, + {"type", 1}, + {"volumes", 1}, + {"writable", 1}, + {NULL} }; + int i; + Tcl_DString oldBuf, newBuf; + + Tcl_DStringInit(&oldBuf); + Tcl_DStringAppend(&oldBuf, "::tcl::file::", -1); + Tcl_DStringInit(&newBuf); + Tcl_DStringAppend(&newBuf, "tcl:file:", -1); + for (i=0 ; unsafeInfo[i].cmdName != NULL ; i++) { + if (unsafeInfo[i].unsafe) { + const char *oldName, *newName; + + Tcl_DStringSetLength(&oldBuf, 13); + oldName = Tcl_DStringAppend(&oldBuf, unsafeInfo[i].cmdName, -1); + Tcl_DStringSetLength(&newBuf, 9); + newName = Tcl_DStringAppend(&newBuf, unsafeInfo[i].cmdName, -1); + if (TclRenameCommand(interp, oldName, "___tmp") != TCL_OK + || Tcl_HideCommand(interp, "___tmp", newName) != TCL_OK) { + Tcl_Panic("problem making 'file %s' safe: %s", + unsafeInfo[i].cmdName, + Tcl_GetString(Tcl_GetObjResult(interp))); + } + } + } + Tcl_DStringFree(&oldBuf); + Tcl_DStringFree(&newBuf); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FileAttrAccessTimeCmd -- + * + * This function is invoked to process the "file atime" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May update the access time on the file, if requested by the user. + * + *---------------------------------------------------------------------- + */ - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); +static int +FileAttrAccessTimeCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_StatBuf buf; + struct utimbuf tval; + + if (objc < 2 || objc > 3) { + Tcl_WrongNumArgs(interp, 1, objv, "name ?time?"); return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[1], fileOptions, "option", 0, - &index) != TCL_OK) { + if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) { return TCL_ERROR; } + if (objc == 3) { + /* + * Need separate variable for reading longs from an object on 64-bit + * platforms. [Bug 698146] + */ - switch ((enum options) index) { + long newTime; - case FCMD_ATIME: - case FCMD_MTIME: - if ((objc < 3) || (objc > 4)) { - Tcl_WrongNumArgs(interp, 2, objv, "name ?time?"); + if (TclGetLongFromObj(interp, objv[2], &newTime) != TCL_OK) { return TCL_ERROR; } - if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { + + tval.actime = newTime; + tval.modtime = buf.st_mtime; + + if (Tcl_FSUtime(objv[1], &tval) != 0) { + Tcl_AppendResult(interp, "could not set access time for file \"", + TclGetString(objv[1]), "\": ", Tcl_PosixError(interp), + NULL); return TCL_ERROR; } - if (objc == 4) { - /* - * Need separate variable for reading longs from an object on - * 64-bit platforms. [Bug #698146] - */ - long newTime; + /* + * Do another stat to ensure that the we return the new recognized + * atime - hopefully the same as the one we sent in. However, fs's + * like FAT don't even know what atime is. + */ - if (TclGetLongFromObj(interp, objv[3], &newTime) != TCL_OK) { - return TCL_ERROR; - } + if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) { + return TCL_ERROR; + } + } - if (index == FCMD_ATIME) { - tval.actime = newTime; - tval.modtime = buf.st_mtime; - } else { /* index == FCMD_MTIME */ - tval.actime = buf.st_atime; - tval.modtime = newTime; - } + Tcl_SetObjResult(interp, Tcl_NewLongObj((long) buf.st_atime)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FileAttrModifyTimeCmd -- + * + * This function is invoked to process the "file mtime" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May update the modification time on the file, if requested by the + * user. + * + *---------------------------------------------------------------------- + */ - if (Tcl_FSUtime(objv[2], &tval) != 0) { - Tcl_AppendResult(interp, "could not set ", - (index == FCMD_ATIME ? "access" : "modification"), - " time for file \"", TclGetString(objv[2]), "\": ", - Tcl_PosixError(interp), NULL); - return TCL_ERROR; - } +static int +FileAttrModifyTimeCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_StatBuf buf; + struct utimbuf tval; - /* - * Do another stat to ensure that the we return the new recognized - * atime - hopefully the same as the one we sent in. However, fs's - * like FAT don't even know what atime is. - */ + if (objc < 2 || objc > 3) { + Tcl_WrongNumArgs(interp, 1, objv, "name ?time?"); + return TCL_ERROR; + } + if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) { + return TCL_ERROR; + } + if (objc == 3) { + /* + * Need separate variable for reading longs from an object on 64-bit + * platforms. [Bug 698146] + */ - if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { - return TCL_ERROR; - } - } + long newTime; - Tcl_SetObjResult(interp, Tcl_NewLongObj((long) - (index == FCMD_ATIME ? buf.st_atime : buf.st_mtime))); - return TCL_OK; - case FCMD_ATTRIBUTES: - return TclFileAttrsCmd(interp, objc, objv); - case FCMD_CHANNELS: - if ((objc < 2) || (objc > 3)) { - Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); + if (TclGetLongFromObj(interp, objv[2], &newTime) != TCL_OK) { return TCL_ERROR; } - return Tcl_GetChannelNamesEx(interp, - ((objc == 2) ? NULL : TclGetString(objv[2]))); - case FCMD_COPY: - return TclFileCopyCmd(interp, objc, objv); - case FCMD_DELETE: - return TclFileDeleteCmd(interp, objc, objv); - case FCMD_DIRNAME: { - Tcl_Obj *dirPtr; - - if (objc != 3) { - goto only3Args; - } - dirPtr = TclPathPart(interp, objv[2], TCL_PATH_DIRNAME); - if (dirPtr == NULL) { + + tval.actime = buf.st_atime; + tval.modtime = newTime; + + if (Tcl_FSUtime(objv[1], &tval) != 0) { + Tcl_AppendResult(interp, "could not set modification time for " + "file \"", TclGetString(objv[1]), "\": ", + Tcl_PosixError(interp), NULL); return TCL_ERROR; } - Tcl_SetObjResult(interp, dirPtr); - Tcl_DecrRefCount(dirPtr); - return TCL_OK; - } - case FCMD_EXECUTABLE: - if (objc != 3) { - goto only3Args; - } - return CheckAccess(interp, objv[2], X_OK); - case FCMD_EXISTS: - if (objc != 3) { - goto only3Args; - } - return CheckAccess(interp, objv[2], F_OK); - case FCMD_EXTENSION: { - Tcl_Obj *ext; - if (objc != 3) { - goto only3Args; - } - ext = TclPathPart(interp, objv[2], TCL_PATH_EXTENSION); - if (ext == NULL) { + /* + * Do another stat to ensure that the we return the new recognized + * mtime - hopefully the same as the one we sent in. + */ + + if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) { return TCL_ERROR; } - Tcl_SetObjResult(interp, ext); - Tcl_DecrRefCount(ext); - return TCL_OK; } - case FCMD_ISDIRECTORY: - if (objc != 3) { - goto only3Args; - } - value = 0; - if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) { - value = S_ISDIR(buf.st_mode); - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); - return TCL_OK; - case FCMD_ISFILE: - if (objc != 3) { - goto only3Args; - } - value = 0; - if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) { - value = S_ISREG(buf.st_mode); - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); - return TCL_OK; - case FCMD_OWNED: - if (objc != 3) { - goto only3Args; - } - value = 0; - if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) { - /* - * For Windows, there are no user ids associated with a file, so - * we always return 1. - * - * TODO: use GetSecurityInfo to get the real owner of the file and - * test for equivalence to the current user. - */ -#if defined(__WIN32__) - value = 1; -#else - value = (geteuid() == buf.st_uid); -#endif - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); - return TCL_OK; - case FCMD_JOIN: { - Tcl_Obj *resObj; + Tcl_SetObjResult(interp, Tcl_NewLongObj((long) buf.st_mtime)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FileAttrLinkStatCmd -- + * + * This function is invoked to process the "file lstat" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Writes to an array named by the user. + * + *---------------------------------------------------------------------- + */ - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?"); - return TCL_ERROR; - } - resObj = Tcl_FSJoinToPath(NULL, objc - 2, objv + 2); - Tcl_SetObjResult(interp, resObj); - return TCL_OK; +static int +FileAttrLinkStatCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_StatBuf buf; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "name varName"); + return TCL_ERROR; + } + if (GetStatBuf(interp, objv[1], Tcl_FSLstat, &buf) != TCL_OK) { + return TCL_ERROR; } - case FCMD_LINK: { - Tcl_Obj *contents; + return StoreStatData(interp, objv[2], &buf); +} + +/* + *---------------------------------------------------------------------- + * + * FileAttrStatCmd -- + * + * This function is invoked to process the "file stat" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Writes to an array named by the user. + * + *---------------------------------------------------------------------- + */ - if (objc < 3 || objc > 5) { - Tcl_WrongNumArgs(interp, 2, objv, "?-linktype? linkname ?target?"); - return TCL_ERROR; - } +static int +FileAttrStatCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_StatBuf buf; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "name varName"); + return TCL_ERROR; + } + if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) { + return TCL_ERROR; + } + return StoreStatData(interp, objv[2], &buf); +} + +/* + *---------------------------------------------------------------------- + * + * FileAttrTypeCmd -- + * + * This function is invoked to process the "file type" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +static int +FileAttrTypeCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_StatBuf buf; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + if (GetStatBuf(interp, objv[1], Tcl_FSLstat, &buf) != TCL_OK) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewStringObj( + GetTypeFromMode((unsigned short) buf.st_mode), -1)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FileAttrSizeCmd -- + * + * This function is invoked to process the "file size" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +FileAttrSizeCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_StatBuf buf; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) buf.st_size)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FileAttrIsDirectoryCmd -- + * + * This function is invoked to process the "file isdirectory" Tcl + * command. See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +FileAttrIsDirectoryCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_StatBuf buf; + int value = 0; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + if (GetStatBuf(NULL, objv[1], Tcl_FSStat, &buf) == TCL_OK) { + value = S_ISDIR(buf.st_mode); + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FileAttrIsExecutableCmd -- + * + * This function is invoked to process the "file executable" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +FileAttrIsExecutableCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + return CheckAccess(interp, objv[1], X_OK); +} + +/* + *---------------------------------------------------------------------- + * + * FileAttrIsExistingCmd -- + * + * This function is invoked to process the "file exists" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +FileAttrIsExistingCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + return CheckAccess(interp, objv[1], F_OK); +} + +/* + *---------------------------------------------------------------------- + * + * FileAttrIsFileCmd -- + * + * This function is invoked to process the "file isfile" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +FileAttrIsFileCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_StatBuf buf; + int value = 0; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + if (GetStatBuf(NULL, objv[1], Tcl_FSStat, &buf) == TCL_OK) { + value = S_ISREG(buf.st_mode); + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FileAttrIsOwnedCmd -- + * + * This function is invoked to process the "file owned" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +FileAttrIsOwnedCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_StatBuf buf; + int value = 0; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + if (GetStatBuf(NULL, objv[1], Tcl_FSStat, &buf) == TCL_OK) { /* - * Index of the 'source' argument. + * For Windows, there are no user ids associated with a file, so we + * always return 1. + * + * TODO: use GetSecurityInfo to get the real owner of the file and + * test for equivalence to the current user. */ - if (objc == 5) { - index = 3; - } else { - index = 2; - } +#ifdef __WIN32__ + value = 1; +#else + value = (geteuid() == buf.st_uid); +#endif + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FileAttrIsReadableCmd -- + * + * This function is invoked to process the "file readable" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - if (objc > 3) { - int linkAction; - if (objc == 5) { - /* - * We have a '-linktype' argument. - */ - - static const char *const linkTypes[] = { - "-symbolic", "-hard", NULL - }; - if (Tcl_GetIndexFromObj(interp, objv[2], linkTypes, "switch", - 0, &linkAction) != TCL_OK) { - return TCL_ERROR; - } - if (linkAction == 0) { - linkAction = TCL_CREATE_SYMBOLIC_LINK; - } else { - linkAction = TCL_CREATE_HARD_LINK; - } - } else { - linkAction = TCL_CREATE_SYMBOLIC_LINK|TCL_CREATE_HARD_LINK; - } - if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) { - return TCL_ERROR; - } +static int +FileAttrIsReadableCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + return CheckAccess(interp, objv[1], R_OK); +} + +/* + *---------------------------------------------------------------------- + * + * FileAttrIsWritableCmd -- + * + * This function is invoked to process the "file writable" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - /* - * Create link from source to target. - */ +static int +FileAttrIsWritableCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + return CheckAccess(interp, objv[1], W_OK); +} + +/* + *---------------------------------------------------------------------- + * + * PathDirNameCmd -- + * + * This function is invoked to process the "file dirname" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - contents = Tcl_FSLink(objv[index], objv[index+1], linkAction); - if (contents == NULL) { - /* - * We handle three common error cases specially, and for all - * other errors, we use the standard posix error message. - */ - - if (errno == EEXIST) { - Tcl_AppendResult(interp, "could not create new link \"", - TclGetString(objv[index]), - "\": that path already exists", NULL); - } else if (errno == ENOENT) { - /* - * There are two cases here: either the target doesn't - * exist, or the directory of the src doesn't exist. - */ - - int access; - Tcl_Obj *dirPtr = TclPathPart(interp, objv[index], - TCL_PATH_DIRNAME); - - if (dirPtr == NULL) { - return TCL_ERROR; - } - access = Tcl_FSAccess(dirPtr, F_OK); - Tcl_DecrRefCount(dirPtr); - if (access != 0) { - Tcl_AppendResult(interp, - "could not create new link \"", - TclGetString(objv[index]), - "\": no such file or directory", NULL); - } else { - Tcl_AppendResult(interp, - "could not create new link \"", - TclGetString(objv[index]), "\": target \"", - TclGetString(objv[index+1]), - "\" doesn't exist", NULL); - } - } else { - Tcl_AppendResult(interp, - "could not create new link \"", - TclGetString(objv[index]), "\" pointing to \"", - TclGetString(objv[index+1]), "\": ", - Tcl_PosixError(interp), NULL); - } - return TCL_ERROR; - } - } else { - if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) { - return TCL_ERROR; - } +static int +PathDirNameCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *dirPtr; - /* - * Read link - */ + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + dirPtr = TclPathPart(interp, objv[1], TCL_PATH_DIRNAME); + if (dirPtr == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, dirPtr); + Tcl_DecrRefCount(dirPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * PathExtensionCmd -- + * + * This function is invoked to process the "file extension" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - contents = Tcl_FSLink(objv[index], NULL, 0); - if (contents == NULL) { - Tcl_AppendResult(interp, "could not read link \"", - TclGetString(objv[index]), "\": ", - Tcl_PosixError(interp), NULL); - return TCL_ERROR; - } - } - Tcl_SetObjResult(interp, contents); - if (objc == 3) { - /* - * If we are reading a link, we need to free this result refCount. - * If we are creating a link, this will just be objv[index+1], and - * so we don't own it. - */ +static int +PathExtensionCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *dirPtr; - Tcl_DecrRefCount(contents); - } - return TCL_OK; + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; } - case FCMD_LSTAT: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "name varName"); - return TCL_ERROR; - } - if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) { - return TCL_ERROR; - } - return StoreStatData(interp, objv[3], &buf); - case FCMD_STAT: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "name varName"); - return TCL_ERROR; - } - if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { - return TCL_ERROR; - } - return StoreStatData(interp, objv[3], &buf); - case FCMD_SIZE: - if (objc != 3) { - goto only3Args; - } - if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, - Tcl_NewWideIntObj((Tcl_WideInt) buf.st_size)); - return TCL_OK; - case FCMD_TYPE: - if (objc != 3) { - goto only3Args; - } - if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_NewStringObj( - GetTypeFromMode((unsigned short) buf.st_mode), -1)); - return TCL_OK; - case FCMD_MKDIR: - return TclFileMakeDirsCmd(interp, objc, objv); - case FCMD_NATIVENAME: { - const char *fileName; - Tcl_DString ds; - - if (objc != 3) { - goto only3Args; - } - fileName = TclGetString(objv[2]); - fileName = Tcl_TranslateFileName(interp, fileName, &ds); - if (fileName == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_NewStringObj(fileName, - Tcl_DStringLength(&ds))); - Tcl_DStringFree(&ds); - return TCL_OK; + dirPtr = TclPathPart(interp, objv[1], TCL_PATH_EXTENSION); + if (dirPtr == NULL) { + return TCL_ERROR; } - case FCMD_NORMALIZE: { - Tcl_Obj *fileName; + Tcl_SetObjResult(interp, dirPtr); + Tcl_DecrRefCount(dirPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * PathRootNameCmd -- + * + * This function is invoked to process the "file root" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "filename"); - return TCL_ERROR; - } +static int +PathRootNameCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *dirPtr; - fileName = Tcl_FSGetNormalizedPath(interp, objv[2]); - if (fileName == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, fileName); - return TCL_OK; + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + dirPtr = TclPathPart(interp, objv[1], TCL_PATH_ROOT); + if (dirPtr == NULL) { + return TCL_ERROR; } - case FCMD_PATHTYPE: { - Tcl_Obj *typeName; + Tcl_SetObjResult(interp, dirPtr); + Tcl_DecrRefCount(dirPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * PathTailCmd -- + * + * This function is invoked to process the "file tail" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - if (objc != 3) { - goto only3Args; - } +static int +PathTailCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *dirPtr; - switch (Tcl_FSGetPathType(objv[2])) { - case TCL_PATH_ABSOLUTE: - TclNewLiteralStringObj(typeName, "absolute"); - break; - case TCL_PATH_RELATIVE: - TclNewLiteralStringObj(typeName, "relative"); - break; - case TCL_PATH_VOLUME_RELATIVE: - TclNewLiteralStringObj(typeName, "volumerelative"); - break; - default: - return TCL_OK; - } - Tcl_SetObjResult(interp, typeName); - return TCL_OK; + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; } - case FCMD_READABLE: - if (objc != 3) { - goto only3Args; - } - return CheckAccess(interp, objv[2], R_OK); - case FCMD_READLINK: { - Tcl_Obj *contents; + dirPtr = TclPathPart(interp, objv[1], TCL_PATH_TAIL); + if (dirPtr == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, dirPtr); + Tcl_DecrRefCount(dirPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * PathFilesystemCmd -- + * + * This function is invoked to process the "file system" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - if (objc != 3) { - goto only3Args; - } +static int +PathFilesystemCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *fsInfo; - if (Tcl_FSConvertToPathType(interp, objv[2]) != TCL_OK) { - return TCL_ERROR; - } + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + fsInfo = Tcl_FSFileSystemInfo(objv[1]); + if (fsInfo == NULL) { + Tcl_SetResult(interp, "unrecognised path", TCL_STATIC); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, fsInfo); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * PathJoinCmd -- + * + * This function is invoked to process the "file join" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +PathJoinCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?"); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_FSJoinToPath(NULL, objc - 1, objv + 1)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * PathNativeNameCmd -- + * + * This function is invoked to process the "file nativename" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - contents = Tcl_FSLink(objv[2], NULL, 0); +static int +PathNativeNameCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + const char *fileName; + Tcl_DString ds; - if (contents == NULL) { - Tcl_AppendResult(interp, "could not readlink \"", - TclGetString(objv[2]), "\": ", Tcl_PosixError(interp), - NULL); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, contents); - Tcl_DecrRefCount(contents); - return TCL_OK; + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; } - case FCMD_RENAME: - return TclFileRenameCmd(interp, objc, objv); - case FCMD_ROOTNAME: { - Tcl_Obj *root; + fileName = Tcl_TranslateFileName(interp, TclGetString(objv[1]), &ds); + if (fileName == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewStringObj(fileName, + Tcl_DStringLength(&ds))); + Tcl_DStringFree(&ds); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * PathNormalizeCmd -- + * + * This function is invoked to process the "file normalize" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - if (objc != 3) { - goto only3Args; - } - root = TclPathPart(interp, objv[2], TCL_PATH_ROOT); - if (root == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, root); - Tcl_DecrRefCount(root); - return TCL_OK; +static int +PathNormalizeCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *fileName; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; } - case FCMD_SEPARATOR: - if ((objc < 2) || (objc > 3)) { - Tcl_WrongNumArgs(interp, 2, objv, "?name?"); - return TCL_ERROR; - } - if (objc == 2) { - const char *separator = NULL; /* lint */ + fileName = Tcl_FSGetNormalizedPath(interp, objv[1]); + if (fileName == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, fileName); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * PathSplitCmd -- + * + * This function is invoked to process the "file split" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - switch (tclPlatform) { - case TCL_PLATFORM_UNIX: - separator = "/"; - break; - case TCL_PLATFORM_WINDOWS: - separator = "\\"; - break; - } - Tcl_SetObjResult(interp, Tcl_NewStringObj(separator, 1)); - } else { - Tcl_Obj *separatorObj = Tcl_FSPathSeparator(objv[2]); +static int +PathSplitCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *res; - if (separatorObj == NULL) { - Tcl_SetResult(interp, "Unrecognised path", TCL_STATIC); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, separatorObj); - } - return TCL_OK; - case FCMD_SPLIT: { - Tcl_Obj *res; + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + res = Tcl_FSSplitPath(objv[1], NULL); + if (res == NULL) { + Tcl_AppendResult(interp, "could not read \"", TclGetString(objv[1]), + "\": no such file or directory", NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, res); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * PathTypeCmd -- + * + * This function is invoked to process the "file pathtype" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - if (objc != 3) { - goto only3Args; - } - res = Tcl_FSSplitPath(objv[2], NULL); - if (res == NULL) { - /* How can the interp be NULL here?! DKF */ - if (interp != NULL) { - Tcl_AppendResult(interp, "could not read \"", - TclGetString(objv[2]), - "\": no such file or directory", NULL); - } - return TCL_ERROR; - } - Tcl_SetObjResult(interp, res); +static int +PathTypeCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *typeName; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + switch (Tcl_FSGetPathType(objv[1])) { + case TCL_PATH_ABSOLUTE: + TclNewLiteralStringObj(typeName, "absolute"); + break; + case TCL_PATH_RELATIVE: + TclNewLiteralStringObj(typeName, "relative"); + break; + case TCL_PATH_VOLUME_RELATIVE: + TclNewLiteralStringObj(typeName, "volumerelative"); + break; + default: + /* Should be unreachable */ return TCL_OK; } - case FCMD_SYSTEM: { - Tcl_Obj *fsInfo; + Tcl_SetObjResult(interp, typeName); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FilesystemSeparatorCmd -- + * + * This function is invoked to process the "file separator" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - if (objc != 3) { - goto only3Args; - } - fsInfo = Tcl_FSFileSystemInfo(objv[2]); - if (fsInfo == NULL) { - Tcl_SetResult(interp, "Unrecognised path", TCL_STATIC); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, fsInfo); - return TCL_OK; +static int +FilesystemSeparatorCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + if (objc < 1 || objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?name?"); + return TCL_ERROR; } - case FCMD_TAIL: { - Tcl_Obj *dirPtr; + if (objc == 1) { + const char *separator = NULL; /* lint */ - if (objc != 3) { - goto only3Args; - } - dirPtr = TclPathPart(interp, objv[2], TCL_PATH_TAIL); - if (dirPtr == NULL) { - return TCL_ERROR; + switch (tclPlatform) { + case TCL_PLATFORM_UNIX: + separator = "/"; + break; + case TCL_PLATFORM_WINDOWS: + separator = "\\"; + break; } - Tcl_SetObjResult(interp, dirPtr); - Tcl_DecrRefCount(dirPtr); - return TCL_OK; - } - case FCMD_TEMPFILE: - return FileTempfileCmd(interp, objc, objv); - case FCMD_VOLUMES: - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj(separator, 1)); + } else { + Tcl_Obj *separatorObj = Tcl_FSPathSeparator(objv[1]); + + if (separatorObj == NULL) { + Tcl_SetResult(interp, "unrecognised path", TCL_STATIC); return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_FSListVolumes()); - return TCL_OK; - case FCMD_WRITABLE: - if (objc != 3) { - goto only3Args; - } - return CheckAccess(interp, objv[2], W_OK); + Tcl_SetObjResult(interp, separatorObj); } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FilesystemVolumesCmd -- + * + * This function is invoked to process the "file volumes" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - only3Args: - Tcl_WrongNumArgs(interp, 2, objv, "name"); - return TCL_ERROR; +static int +FilesystemVolumesCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_FSListVolumes()); + return TCL_OK; } /* @@ -1590,13 +2204,13 @@ StoreStatData( */ #define STORE_ARY(fieldName, object) \ - TclNewLiteralStringObj(field, fieldName); \ - Tcl_IncrRefCount(field); \ - value = (object); \ + TclNewLiteralStringObj(field, fieldName); \ + Tcl_IncrRefCount(field); \ + value = (object); \ if (Tcl_ObjSetVar2(interp,varName,field,value,TCL_LEAVE_ERR_MSG)==NULL) { \ - TclDecrRefCount(field); \ - return TCL_ERROR; \ - } \ + TclDecrRefCount(field); \ + return TCL_ERROR; \ + } \ TclDecrRefCount(field); /* @@ -1670,165 +2284,6 @@ GetTypeFromMode( } /* - *--------------------------------------------------------------------------- - * - * FileTempfileCmd - * - * This function implements the "tempfile" subcommand of the "file" - * command. - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * Creates a temporary file. Opens a channel to that file and puts the - * name of that channel in the result. *Might* register suitable exit - * handlers to ensure that the temporary file gets deleted. Might write - * to a variable, so reentrancy is a potential issue. - * - *--------------------------------------------------------------------------- - */ - -static int -FileTempfileCmd( - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_Obj *nameVarObj = NULL; /* Variable to store the name of the temporary - * file in. */ - Tcl_Obj *nameObj = NULL; /* Object that will contain the filename. */ - Tcl_Channel chan; /* The channel opened (RDWR) on the temporary - * file, or NULL if there's an error. */ - Tcl_Obj *tempDirObj = NULL, *tempBaseObj = NULL, *tempExtObj = NULL; - /* Pieces of template. Each piece is NULL if - * it is omitted. The platform temporary file - * engine might ignore some pieces. */ - - if (objc < 2 || objc > 4) { - Tcl_WrongNumArgs(interp, 2, objv, "?nameVar? ?template?"); - return TCL_ERROR; - } - - if (objc > 2) { - nameVarObj = objv[2]; - TclNewObj(nameObj); - } - if (objc > 3) { - int length; - const char *string = TclGetStringFromObj(objv[3], &length); - - /* - * Treat an empty string as if it wasn't there. - */ - - if (length == 0) { - goto makeTemporary; - } - - /* - * The template only gives a directory if there is a directory - * separator in it. - */ - - if (strchr(string, '/') != NULL - || (tclPlatform == TCL_PLATFORM_WINDOWS - && strchr(string, '\\') != NULL)) { - tempDirObj = TclPathPart(interp, objv[3], TCL_PATH_DIRNAME); - - /* - * Only allow creation of temporary files in the native filesystem - * since they are frequently used for integration with external - * tools or system libraries. [Bug 2388866] - */ - - if (tempDirObj != NULL && Tcl_FSGetFileSystemForPath(tempDirObj) - != &tclNativeFilesystem) { - TclDecrRefCount(tempDirObj); - tempDirObj = NULL; - } - } - - /* - * The template only gives the filename if the last character isn't a - * directory separator. - */ - - if (string[length-1] != '/' && (tclPlatform != TCL_PLATFORM_WINDOWS - || string[length-1] != '\\')) { - Tcl_Obj *tailObj = TclPathPart(interp, objv[3], TCL_PATH_TAIL); - - if (tailObj != NULL) { - tempBaseObj = TclPathPart(interp, tailObj, TCL_PATH_ROOT); - tempExtObj = TclPathPart(interp, tailObj, TCL_PATH_EXTENSION); - TclDecrRefCount(tailObj); - } - } - } - - /* - * Convert empty parts of the template into unspecified parts. - */ - - if (tempDirObj && !TclGetString(tempDirObj)[0]) { - TclDecrRefCount(tempDirObj); - tempDirObj = NULL; - } - if (tempBaseObj && !TclGetString(tempBaseObj)[0]) { - TclDecrRefCount(tempBaseObj); - tempBaseObj = NULL; - } - if (tempExtObj && !TclGetString(tempExtObj)[0]) { - TclDecrRefCount(tempExtObj); - tempExtObj = NULL; - } - - /* - * Create and open the temporary file. - */ - - makeTemporary: - chan = TclpOpenTemporaryFile(tempDirObj,tempBaseObj,tempExtObj, nameObj); - - /* - * If we created pieces of template, get rid of them now. - */ - - if (tempDirObj) { - TclDecrRefCount(tempDirObj); - } - if (tempBaseObj) { - TclDecrRefCount(tempBaseObj); - } - if (tempExtObj) { - TclDecrRefCount(tempExtObj); - } - - /* - * Deal with results. - */ - - if (chan == NULL) { - if (nameVarObj) { - TclDecrRefCount(nameObj); - } - Tcl_AppendResult(interp, "can't create temporary file: ", - Tcl_PosixError(interp), NULL); - return TCL_ERROR; - } - Tcl_RegisterChannel(interp, chan); - if (nameVarObj != NULL) { - if (Tcl_ObjSetVar2(interp, nameVarObj, NULL, nameObj, - TCL_LEAVE_ERR_MSG) == NULL) { - Tcl_UnregisterChannel(interp, chan); - return TCL_ERROR; - } - } - Tcl_AppendResult(interp, Tcl_GetChannelName(chan), NULL); - return TCL_OK; -} - -/* *---------------------------------------------------------------------- * * Tcl_ForObjCmd -- diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index c4750c5..cfdeb94 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclEnsemble.c,v 1.5 2010/03/05 14:34:04 dkf Exp $ + * RCS: @(#) $Id: tclEnsemble.c,v 1.6 2010/12/09 15:09:07 dkf Exp $ */ #include "tclInt.h" @@ -1417,16 +1417,21 @@ TclMakeEnsemble( { Tcl_Command ensemble; Tcl_Namespace *ns; - Tcl_DString buf; + Tcl_DString buf, hiddenBuf; const char **nameParts = NULL; const char *cmdName = NULL; - int i, nameCount = 0, ensembleFlags = 0; + int i, nameCount = 0, ensembleFlags = 0, hiddenLen; /* * Construct the path for the ensemble namespace and create it. */ Tcl_DStringInit(&buf); + Tcl_DStringInit(&hiddenBuf); + Tcl_DStringAppend(&hiddenBuf, "tcl:", -1); + Tcl_DStringAppend(&hiddenBuf, name, -1); + Tcl_DStringAppend(&hiddenBuf, ":", -1); + hiddenLen = Tcl_DStringLength(&hiddenBuf); if (name[0] == ':' && name[1] == ':') { /* * An absolute name, so use it directly. @@ -1491,10 +1496,35 @@ TclMakeEnsemble( Tcl_DStringLength(&buf)); Tcl_AppendToObj(toObj, map[i].name, -1); Tcl_DictObjPut(NULL, mapDict, fromObj, toObj); + if (map[i].proc || map[i].nreProc) { - cmdPtr = (Command *) - Tcl_NRCreateCommand(interp, TclGetString(toObj), - map[i].proc, map[i].nreProc, map[i].clientData, NULL); + /* + * If the command is unsafe, hide it when we're in a safe + * interpreter. The code to do this is really hokey! It also + * doesn't work properly yet; this function is always + * currently called before the safe-interp flag is set so the + * Tcl_IsSafe check fails. + */ + + if (map[i].unsafe && Tcl_IsSafe(interp)) { + cmdPtr = (Command *) + Tcl_NRCreateCommand(interp, "___tmp", map[i].proc, + map[i].nreProc, map[i].clientData, NULL); + Tcl_DStringSetLength(&hiddenBuf, hiddenLen); + if (Tcl_HideCommand(interp, "___tmp", + Tcl_DStringAppend(&hiddenBuf, map[i].name, -1))) { + Tcl_Panic(Tcl_GetString(Tcl_GetObjResult(interp))); + } + } else { + /* + * Not hidden, so just create it. Yay! + */ + + cmdPtr = (Command *) + Tcl_NRCreateCommand(interp, TclGetString(toObj), + map[i].proc, map[i].nreProc, map[i].clientData, + NULL); + } cmdPtr->compileProc = map[i].compileProc; if (map[i].compileProc != NULL) { ensembleFlags |= ENSEMBLE_COMPILE; @@ -1508,6 +1538,7 @@ TclMakeEnsemble( } Tcl_DStringFree(&buf); + Tcl_DStringFree(&hiddenBuf); if (nameParts != NULL) { Tcl_Free((char *) nameParts); } diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 8ff6e39..050c5dc 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -9,10 +9,11 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclFCmd.c,v 1.51 2010/02/24 10:32:17 dkf Exp $ + * RCS: @(#) $Id: tclFCmd.c,v 1.52 2010/12/09 15:09:07 dkf Exp $ */ #include "tclInt.h" +#include "tclFileSystem.h" /* * Declarations for local functions defined in this file: @@ -48,6 +49,7 @@ static int FileForceOption(Tcl_Interp *interp, int TclFileRenameCmd( + ClientData clientData, /* Unused */ Tcl_Interp *interp, /* Interp for error reporting or recursive * calls in the case of a tricky rename. */ int objc, /* Number of arguments. */ @@ -76,6 +78,7 @@ TclFileRenameCmd( int TclFileCopyCmd( + ClientData clientData, /* Unused */ Tcl_Interp *interp, /* Used for error reporting or recursive calls * in the case of a tricky copy. */ int objc, /* Number of arguments. */ @@ -113,22 +116,20 @@ FileCopyRename( Tcl_StatBuf statBuf; Tcl_Obj *target; - i = FileForceOption(interp, objc - 2, objv + 2, &force); + i = FileForceOption(interp, objc - 1, objv + 1, &force); if (i < 0) { return TCL_ERROR; } - i += 2; + i++; if ((objc - i) < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - TclGetString(objv[0]), " ", TclGetString(objv[1]), - " ?-option value ...? source ?source ...? target\"", NULL); + Tcl_WrongNumArgs(interp, 1, objv, + "?-option value ...? source ?source ...? target"); return TCL_ERROR; } /* - * If target doesn't exist or isn't a directory, try the copy/rename. - * More than 2 arguments is only valid if the target is an existing - * directory. + * If target doesn't exist or isn't a directory, try the copy/rename. More + * than 2 arguments is only valid if the target is an existing directory. */ target = objv[objc - 1]; @@ -218,26 +219,25 @@ FileCopyRename( int TclFileMakeDirsCmd( + ClientData clientData, /* Unused */ Tcl_Interp *interp, /* Used for error reporting. */ int objc, /* Number of arguments */ Tcl_Obj *const objv[]) /* Argument strings passed to Tcl_FileCmd. */ { - Tcl_Obj *errfile; + Tcl_Obj *errfile = NULL; int result, i, j, pobjc; Tcl_Obj *split = NULL; Tcl_Obj *target = NULL; Tcl_StatBuf statBuf; - errfile = NULL; - result = TCL_OK; - for (i = 2; i < objc; i++) { + for (i = 1; i < objc; i++) { if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) { result = TCL_ERROR; break; } - split = Tcl_FSSplitPath(objv[i],&pobjc); + split = Tcl_FSSplitPath(objv[i], &pobjc); Tcl_IncrRefCount(split); if (pobjc == 0) { errno = ENOENT; @@ -274,19 +274,17 @@ TclFileMakeDirsCmd( * subdirectory. */ - if (errno == EEXIST) { - if ((Tcl_FSStat(target, &statBuf) == 0) - && S_ISDIR(statBuf.st_mode)) { - /* - * It is a directory that wasn't there before, so keep - * going without error. - */ - - Tcl_ResetResult(interp); - } else { - errfile = target; - goto done; - } + if (errno != EEXIST) { + errfile = target; + goto done; + } else if ((Tcl_FSStat(target, &statBuf) == 0) + && S_ISDIR(statBuf.st_mode)) { + /* + * It is a directory that wasn't there before, so keep + * going without error. + */ + + Tcl_ResetResult(interp); } else { errfile = target; goto done; @@ -338,6 +336,7 @@ TclFileMakeDirsCmd( int TclFileDeleteCmd( + ClientData clientData, /* Unused */ Tcl_Interp *interp, /* Used for error reporting */ int objc, /* Number of arguments */ Tcl_Obj *const objv[]) /* Argument strings passed to Tcl_FileCmd. */ @@ -346,16 +345,15 @@ TclFileDeleteCmd( Tcl_Obj *errfile; Tcl_Obj *errorBuffer = NULL; - i = FileForceOption(interp, objc - 2, objv + 2, &force); + i = FileForceOption(interp, objc - 1, objv + 1, &force); if (i < 0) { return TCL_ERROR; } - i += 2; errfile = NULL; result = TCL_OK; - for ( ; i < objc; i++) { + for (i++ ; i < objc; i++) { Tcl_StatBuf statBuf; errfile = objv[i]; @@ -821,22 +819,25 @@ FileForceOption( int *forcePtr) /* If the "-force" was specified, *forcePtr is * filled with 1, otherwise with 0. */ { - int force, i; + int force, i, idx; + static const char *const options[] = { + "-force", "--", NULL + }; force = 0; for (i = 0; i < objc; i++) { if (TclGetString(objv[i])[0] != '-') { break; } - if (strcmp(TclGetString(objv[i]), "-force") == 0) { + if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", TCL_EXACT, + &idx) != TCL_OK) { + return -1; + } + if (idx == 0 /* -force */) { force = 1; - } else if (strcmp(TclGetString(objv[i]), "--") == 0) { + } else { /* -- */ i++; break; - } else { - Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[i]), - "\": should be -force or --", NULL); - return -1; } } *forcePtr = force; @@ -940,6 +941,7 @@ FileBasename( int TclFileAttrsCmd( + ClientData clientData, /* Unused */ Tcl_Interp *interp, /* The interpreter for error reporting. */ int objc, /* Number of command line arguments. */ Tcl_Obj *const objv[]) /* The command line objects. */ @@ -951,19 +953,18 @@ TclFileAttrsCmd( int numObjStrings = -1; Tcl_Obj *filePtr; - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, - "name ?-option value ...?"); + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name ?-option value ...?"); return TCL_ERROR; } - filePtr = objv[2]; + filePtr = objv[1]; if (Tcl_FSConvertToPathType(interp, filePtr) != TCL_OK) { return TCL_ERROR; } - objc -= 3; - objv += 3; + objc -= 2; + objv += 2; result = TCL_ERROR; Tcl_SetErrno(0); @@ -1125,6 +1126,362 @@ TclFileAttrsCmd( } /* + *---------------------------------------------------------------------- + * + * TclFileLinkCmd -- + * + * This function is invoked to process the "file link" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May create a new link. + * + *---------------------------------------------------------------------- + */ + +int +TclFileLinkCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *contents; + int index; + + if (objc < 2 || objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, "?-linktype? linkname ?target?"); + return TCL_ERROR; + } + + /* + * Index of the 'source' argument. + */ + + if (objc == 4) { + index = 2; + } else { + index = 1; + } + + if (objc > 2) { + int linkAction; + + if (objc == 4) { + /* + * We have a '-linktype' argument. + */ + + static const char *const linkTypes[] = { + "-symbolic", "-hard", NULL + }; + if (Tcl_GetIndexFromObj(interp, objv[1], linkTypes, "switch", 0, + &linkAction) != TCL_OK) { + return TCL_ERROR; + } + if (linkAction == 0) { + linkAction = TCL_CREATE_SYMBOLIC_LINK; + } else { + linkAction = TCL_CREATE_HARD_LINK; + } + } else { + linkAction = TCL_CREATE_SYMBOLIC_LINK | TCL_CREATE_HARD_LINK; + } + if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Create link from source to target. + */ + + contents = Tcl_FSLink(objv[index], objv[index+1], linkAction); + if (contents == NULL) { + /* + * We handle three common error cases specially, and for all other + * errors, we use the standard posix error message. + */ + + if (errno == EEXIST) { + Tcl_AppendResult(interp, "could not create new link \"", + TclGetString(objv[index]), + "\": that path already exists", NULL); + } else if (errno == ENOENT) { + /* + * There are two cases here: either the target doesn't exist, + * or the directory of the src doesn't exist. + */ + + int access; + Tcl_Obj *dirPtr = TclPathPart(interp, objv[index], + TCL_PATH_DIRNAME); + + if (dirPtr == NULL) { + return TCL_ERROR; + } + access = Tcl_FSAccess(dirPtr, F_OK); + Tcl_DecrRefCount(dirPtr); + if (access != 0) { + Tcl_AppendResult(interp, "could not create new link \"", + TclGetString(objv[index]), + "\": no such file or directory", NULL); + } else { + Tcl_AppendResult(interp, "could not create new link \"", + TclGetString(objv[index]), "\": target \"", + TclGetString(objv[index+1]), "\" doesn't exist", + NULL); + } + } else { + Tcl_AppendResult(interp, "could not create new link \"", + TclGetString(objv[index]), "\" pointing to \"", + TclGetString(objv[index+1]), "\": ", + Tcl_PosixError(interp), NULL); + } + return TCL_ERROR; + } + } else { + if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Read link + */ + + contents = Tcl_FSLink(objv[index], NULL, 0); + if (contents == NULL) { + Tcl_AppendResult(interp, "could not read link \"", + TclGetString(objv[index]), "\": ", Tcl_PosixError(interp), + NULL); + return TCL_ERROR; + } + } + Tcl_SetObjResult(interp, contents); + if (objc == 2) { + /* + * If we are reading a link, we need to free this result refCount. If + * we are creating a link, this will just be objv[index+1], and so we + * don't own it. + */ + + Tcl_DecrRefCount(contents); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclFileReadLinkCmd -- + * + * This function is invoked to process the "file readlink" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclFileReadLinkCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *contents; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + + if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) { + return TCL_ERROR; + } + + contents = Tcl_FSLink(objv[1], NULL, 0); + + if (contents == NULL) { + Tcl_AppendResult(interp, "could not readlink \"", + TclGetString(objv[1]), "\": ", Tcl_PosixError(interp), NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, contents); + Tcl_DecrRefCount(contents); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * TclFileTemporaryCmd + * + * This function implements the "tempfile" subcommand of the "file" + * command. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * Creates a temporary file. Opens a channel to that file and puts the + * name of that channel in the result. *Might* register suitable exit + * handlers to ensure that the temporary file gets deleted. Might write + * to a variable, so reentrancy is a potential issue. + * + *--------------------------------------------------------------------------- + */ + +int +TclFileTemporaryCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *nameVarObj = NULL; /* Variable to store the name of the temporary + * file in. */ + Tcl_Obj *nameObj = NULL; /* Object that will contain the filename. */ + Tcl_Channel chan; /* The channel opened (RDWR) on the temporary + * file, or NULL if there's an error. */ + Tcl_Obj *tempDirObj = NULL, *tempBaseObj = NULL, *tempExtObj = NULL; + /* Pieces of template. Each piece is NULL if + * it is omitted. The platform temporary file + * engine might ignore some pieces. */ + + if (objc < 1 || objc > 3) { + Tcl_WrongNumArgs(interp, 1, objv, "?nameVar? ?template?"); + return TCL_ERROR; + } + + if (objc > 1) { + nameVarObj = objv[1]; + TclNewObj(nameObj); + } + if (objc > 2) { + int length; + Tcl_Obj *templateObj = objv[2]; + const char *string = TclGetStringFromObj(templateObj, &length); + + /* + * Treat an empty string as if it wasn't there. + */ + + if (length == 0) { + goto makeTemporary; + } + + /* + * The template only gives a directory if there is a directory + * separator in it. + */ + + if (strchr(string, '/') != NULL + || (tclPlatform == TCL_PLATFORM_WINDOWS + && strchr(string, '\\') != NULL)) { + tempDirObj = TclPathPart(interp, templateObj, TCL_PATH_DIRNAME); + + /* + * Only allow creation of temporary files in the native filesystem + * since they are frequently used for integration with external + * tools or system libraries. [Bug 2388866] + */ + + if (tempDirObj != NULL && Tcl_FSGetFileSystemForPath(tempDirObj) + != &tclNativeFilesystem) { + TclDecrRefCount(tempDirObj); + tempDirObj = NULL; + } + } + + /* + * The template only gives the filename if the last character isn't a + * directory separator. + */ + + if (string[length-1] != '/' && (tclPlatform != TCL_PLATFORM_WINDOWS + || string[length-1] != '\\')) { + Tcl_Obj *tailObj = TclPathPart(interp, templateObj, + TCL_PATH_TAIL); + + if (tailObj != NULL) { + tempBaseObj = TclPathPart(interp, tailObj, TCL_PATH_ROOT); + tempExtObj = TclPathPart(interp, tailObj, TCL_PATH_EXTENSION); + TclDecrRefCount(tailObj); + } + } + } + + /* + * Convert empty parts of the template into unspecified parts. + */ + + if (tempDirObj && !TclGetString(tempDirObj)[0]) { + TclDecrRefCount(tempDirObj); + tempDirObj = NULL; + } + if (tempBaseObj && !TclGetString(tempBaseObj)[0]) { + TclDecrRefCount(tempBaseObj); + tempBaseObj = NULL; + } + if (tempExtObj && !TclGetString(tempExtObj)[0]) { + TclDecrRefCount(tempExtObj); + tempExtObj = NULL; + } + + /* + * Create and open the temporary file. + */ + + makeTemporary: + chan = TclpOpenTemporaryFile(tempDirObj,tempBaseObj,tempExtObj, nameObj); + + /* + * If we created pieces of template, get rid of them now. + */ + + if (tempDirObj) { + TclDecrRefCount(tempDirObj); + } + if (tempBaseObj) { + TclDecrRefCount(tempBaseObj); + } + if (tempExtObj) { + TclDecrRefCount(tempExtObj); + } + + /* + * Deal with results. + */ + + if (chan == NULL) { + if (nameVarObj) { + TclDecrRefCount(nameObj); + } + Tcl_AppendResult(interp, "can't create temporary file: ", + Tcl_PosixError(interp), NULL); + return TCL_ERROR; + } + Tcl_RegisterChannel(interp, chan); + if (nameVarObj != NULL) { + if (Tcl_ObjSetVar2(interp, nameVarObj, NULL, nameObj, + TCL_LEAVE_ERR_MSG) == NULL) { + Tcl_UnregisterChannel(interp, chan); + return TCL_ERROR; + } + } + Tcl_AppendResult(interp, Tcl_GetChannelName(chan), NULL); + return TCL_OK; +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 696b3ac..59d7b3b 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.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: tclIOCmd.c,v 1.69 2010/08/22 18:53:26 nijtmans Exp $ + * RCS: @(#) $Id: tclIOCmd.c,v 1.70 2010/12/09 15:09:07 dkf Exp $ */ #include "tclInt.h" @@ -1898,6 +1898,39 @@ ChanPipeObjCmd( /* *---------------------------------------------------------------------- * + * TclChannelNamesCmd -- + * + * This function is invoked to process the "chan names" and "file + * channels" Tcl commands. See the user documentation for details on + * what they do. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclChannelNamesCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + if (objc < 1 || objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); + return TCL_ERROR; + } + return Tcl_GetChannelNamesEx(interp, + ((objc == 1) ? NULL : TclGetString(objv[1]))); +} + +/* + *---------------------------------------------------------------------- + * * TclInitChanCmd -- * * This function is invoked to create the "chan" Tcl command. See the @@ -1932,6 +1965,7 @@ TclInitChanCmd( {"event", Tcl_FileEventObjCmd, NULL, NULL, NULL}, {"flush", Tcl_FlushObjCmd, NULL, NULL, NULL}, {"gets", Tcl_GetsObjCmd, NULL, NULL, NULL}, + {"names", TclChannelNamesCmd}, {"pending", ChanPendingObjCmd, NULL, NULL, NULL}, /* TIP #287 */ {"pop", TclChanPopObjCmd, NULL, NULL, NULL}, /* TIP #230 */ {"postevent", TclChanPostEventObjCmd, NULL, NULL, NULL}, /* TIP #219 */ @@ -1946,7 +1980,6 @@ TclInitChanCmd( }; static const char *const extras[] = { "configure", "::fconfigure", - "names", "::file channels", NULL }; Tcl_Command ensemble; diff --git a/generic/tclInt.h b/generic/tclInt.h index 2d36154..d107f2c 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.488 2010/11/30 18:17:26 hobbs Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.489 2010/12/09 15:09:08 dkf Exp $ */ #ifndef _TCLINT @@ -1601,6 +1601,8 @@ typedef struct { CompileProc *compileProc; /* The compiler for the subcommand. */ Tcl_ObjCmdProc *nreProc; /* NRE implementation of this command. */ ClientData clientData; /* Any clientData to give the command. */ + int unsafe; /* Whether this command is to be hidden by + * default in a safe interpreter. */ } EnsembleImplMap; /* @@ -2858,6 +2860,7 @@ MODULE_SCOPE int TclCheckBadOctal(Tcl_Interp *interp, const char *value); MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp, Tcl_Channel chan); +MODULE_SCOPE Tcl_ObjCmdProc TclChannelNamesCmd; MODULE_SCOPE int TclClearRootEnsemble(ClientData data[], Tcl_Interp *interp, int result); MODULE_SCOPE void TclCleanupLiteralTable(Tcl_Interp *interp, @@ -2874,16 +2877,14 @@ MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr); MODULE_SCOPE int TclEvalEx(Tcl_Interp *interp, const char *script, int numBytes, int flags, int line, int *clNextOuter, const char *outerScript); -MODULE_SCOPE int TclFileAttrsCmd(Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int TclFileCopyCmd(Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int TclFileDeleteCmd(Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int TclFileMakeDirsCmd(Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int TclFileRenameCmd(Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclFileAttrsCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclFileCopyCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclFileDeleteCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclFileLinkCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclFileMakeDirsCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclFileReadLinkCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclFileRenameCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclFileTemporaryCmd; MODULE_SCOPE void TclCreateLateExitHandler(Tcl_ExitProc *proc, ClientData clientData); MODULE_SCOPE void TclDeleteLateExitHandler(Tcl_ExitProc *proc, @@ -3225,9 +3226,8 @@ MODULE_SCOPE int Tcl_FconfigureObjCmd( MODULE_SCOPE int Tcl_FcopyObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_FileObjCmd(ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_Command TclInitFileCmd(Tcl_Interp *interp); +MODULE_SCOPE int TclMakeFileCommandSafe(Tcl_Interp *interp); MODULE_SCOPE int Tcl_FileEventObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); diff --git a/tests/cmdAH.test b/tests/cmdAH.test index f7ba584..ab388b9 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -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: cmdAH.test,v 1.68 2010/02/05 14:33:09 dkf Exp $ +# RCS: @(#) $Id: cmdAH.test,v 1.69 2010/12/09 15:09:08 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 @@ -218,10 +218,10 @@ test cmdAH-4.13 {Tcl_EncodingObjCmd} -setup { test cmdAH-5.1 {Tcl_FileObjCmd} -returnCodes error -body { file -} -result {wrong # args: should be "file option ?arg ...?"} +} -result {wrong # args: should be "file subcommand ?arg ...?"} test cmdAH-5.2 {Tcl_FileObjCmd} -returnCodes error -body { file x -} -result {bad option "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempfile, type, volumes, or writable} +} -result {unknown or ambiguous subcommand "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempfile, type, volumes, or writable} test cmdAH-5.3 {Tcl_FileObjCmd} -returnCodes error -body { file exists } -result {wrong # args: should be "file exists name"} @@ -242,7 +242,7 @@ test cmdAH-6.3 {Tcl_FileObjCmd: volumes} {unix} { } {0} test cmdAH-6.4 {Tcl_FileObjCmd: volumes} win { set volumeList [string tolower [file volumes]] - list [catch {lsearch $volumeList "c:/"} element] [expr $element != -1] [catch {list glob -nocomplain [lindex $volumeList $element]*}] + list [catch {lsearch $volumeList "c:/"} element] [expr {$element != -1}] [catch {list glob -nocomplain [lindex $volumeList $element]*}] } {0 1 0} # attributes @@ -1415,25 +1415,25 @@ test cmdAH-29.5 {Tcl_FileObjCmd: type} { # Error conditions test cmdAH-30.1 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file gorp x -} -result {bad option "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempfile, type, volumes, or writable} +} -result {unknown or ambiguous subcommand "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempfile, type, volumes, or writable} test cmdAH-30.2 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file ex x -} -match glob -result {ambiguous option "ex": must be *} +} -match glob -result {unknown or ambiguous subcommand "ex": must be *} test cmdAH-30.3 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file is x -} -match glob -result {ambiguous option "is": must be *} +} -match glob -result {unknown or ambiguous subcommand "is": must be *} test cmdAH-30.4 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file z x -} -match glob -result {bad option "z": must be *} +} -match glob -result {unknown or ambiguous subcommand "z": must be *} test cmdAH-30.5 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file read x -} -match glob -result {ambiguous option "read": must be *} +} -match glob -result {unknown or ambiguous subcommand "read": must be *} test cmdAH-30.6 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file s x -} -match glob -result {ambiguous option "s": must be *} +} -match glob -result {unknown or ambiguous subcommand "s": must be *} test cmdAH-30.7 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file t x -} -match glob -result {ambiguous option "t": must be *} +} -match glob -result {unknown or ambiguous subcommand "t": must be *} test cmdAH-30.8 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file dirname ~woohgy } -result {user "woohgy" doesn't exist} @@ -1445,7 +1445,7 @@ test cmdAH-30.8 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { interp create simpleInterp interp create -safe safeInterp interp create -safeInterp expose file file +catch {safeInterp expose file file} test cmdAH-31.1 {Tcl_FileObjCmd: channels, too many args} -body { file channels a b diff --git a/tests/fCmd.test b/tests/fCmd.test index 4057cd0..960844c 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.test @@ -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: fCmd.test,v 1.71 2010/12/07 16:32:06 dkf Exp $ +# RCS: @(#) $Id: fCmd.test,v 1.72 2010/12/09 15:09:08 dkf Exp $ # if {"::tcltest" ni [namespace children]} { @@ -195,7 +195,7 @@ test fCmd-2.1 {TclFileCopyCmd} -constraints {notRoot} -setup { test fCmd-3.1 {FileCopyRename: FileForceOption fails} -constraints {notRoot} -body { file rename -xyz -} -returnCodes error -result {bad option "-xyz": should be -force or --} +} -returnCodes error -result {bad option "-xyz": must be -force or --} test fCmd-3.2 {FileCopyRename: not enough args} -constraints {notRoot} -body { file rename xyz } -returnCodes error -result {wrong # args: should be "file rename ?-option value ...? source ?source ...? target"} @@ -393,7 +393,7 @@ test fCmd-4.16 {TclFileMakeDirsCmd: TclpCreateDirectory succeeds} -setup { test fCmd-5.1 {TclFileDeleteCmd: FileForceOption fails} -constraints {notRoot} -body { file delete -xyz -} -returnCodes error -result {bad option "-xyz": should be -force or --} +} -returnCodes error -result {bad option "-xyz": must be -force or --} test fCmd-5.2 {TclFileDeleteCmd: accept 0 files (TIP 323)} -body { file delete -force -force } -result {} @@ -740,7 +740,7 @@ test fCmd-7.4 {FileForceOption: bad option} -constraints {notRoot} -setup { file delete -tf1 } -returnCodes error -cleanup { file delete -- -tf1 -} -result {bad option "-tf1": should be -force or --} +} -result {bad option "-tf1": must be -force or --} test fCmd-7.5 {FileForceOption: multiple times through loop} -setup { cleanup } -constraints {notRoot} -returnCodes error -body { diff --git a/tests/fileSystem.test b/tests/fileSystem.test index 2fe13d7..1691eb5 100644 --- a/tests/fileSystem.test +++ b/tests/fileSystem.test @@ -600,14 +600,14 @@ test filesystem-6.25 {empty file name} -returnCodes error -body { test filesystem-6.26 {empty file name} {file rootname ""} {} test filesystem-6.27 {empty file name} -returnCodes error -body { file separator "" -} -result {Unrecognised path} +} -result {unrecognised path} test filesystem-6.28 {empty file name} -returnCodes error -body { file size "" } -result {could not read "": no such file or directory} test filesystem-6.29 {empty file name} {file split ""} {} test filesystem-6.30 {empty file name} -returnCodes error -body { file system "" -} -result {Unrecognised path} +} -result {unrecognised path} test filesystem-6.31 {empty file name} {file tail ""} {} test filesystem-6.32 {empty file name} -returnCodes error -body { file type "" diff --git a/tests/interp.test b/tests/interp.test index f73fe49..6df8f31e 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -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: interp.test,v 1.69 2010/11/15 21:34:54 andreas_kupries Exp $ +# RCS: @(#) $Id: interp.test,v 1.70 2010/12/09 15:09:08 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 @@ -19,7 +19,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { testConstraint testinterpdelete [llength [info commands testinterpdelete]] -set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source unload} +set hidden_cmds {cd encoding exec exit fconfigure glob load open pwd socket source tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempfile tcl:file:type tcl:file:volumes tcl:file:writable unload} foreach i [interp slaves] { interp delete $i @@ -1607,67 +1607,73 @@ test interp-21.1 {interp hidden} { test interp-21.2 {interp hidden} { interp hidden } "" -test interp-21.3 {interp hidden vs interp hide, interp expose} { +test interp-21.3 {interp hidden vs interp hide, interp expose} -setup { set l "" +} -body { lappend l [interp hidden] interp hide {} pwd lappend l [interp hidden] interp expose {} pwd lappend l [interp hidden] - set l -} {{} pwd {}} -test interp-21.4 {interp hidden} { +} -result {{} pwd {}} +test interp-21.4 {interp hidden} -setup { catch {interp delete a} +} -body { interp create a - set l [interp hidden a] + interp hidden a +} -cleanup { interp delete a - set l -} "" -test interp-21.5 {interp hidden} { +} -result "" +test interp-21.5 {interp hidden} -setup { catch {interp delete a} +} -body { interp create -safe a - set l [lsort [interp hidden a]] + lsort [interp hidden a] +} -cleanup { interp delete a - set l -} $hidden_cmds -test interp-21.6 {interp hidden vs interp hide, interp expose} { +} -result $hidden_cmds +test interp-21.6 {interp hidden vs interp hide, interp expose} -setup { catch {interp delete a} - interp create a set l "" +} -body { + interp create a lappend l [interp hidden a] interp hide a pwd lappend l [interp hidden a] interp expose a pwd lappend l [interp hidden a] +} -cleanup { interp delete a - set l -} {{} pwd {}} -test interp-21.7 {interp hidden} { +} -result {{} pwd {}} +test interp-21.7 {interp hidden} -setup { catch {interp delete a} +} -body { interp create a - set l [a hidden] + a hidden +} -cleanup { interp delete a - set l -} "" -test interp-21.8 {interp hidden} { +} -result "" +test interp-21.8 {interp hidden} -setup { catch {interp delete a} +} -body { interp create a -safe - set l [lsort [a hidden]] + lsort [a hidden] +} -cleanup { interp delete a - set l -} $hidden_cmds -test interp-21.9 {interp hidden vs interp hide, interp expose} { +} -result $hidden_cmds +test interp-21.9 {interp hidden vs interp hide, interp expose} -setup { catch {interp delete a} - interp create a set l "" +} -body { + interp create a lappend l [a hidden] a hide pwd lappend l [a hidden] a expose pwd lappend l [a hidden] +} -cleanup { interp delete a - set l -} {{} pwd {}} +} -result {{} pwd {}} test interp-22.1 {testing interp marktrusted} { catch {interp delete a} @@ -1767,183 +1773,161 @@ test interp-22.9 {testing interp marktrusted} { set l } {1 1 1 0 0} -test interp-23.1 {testing hiding vs aliases} { +test interp-23.1 {testing hiding vs aliases: unsafe interp} -setup { catch {interp delete a} - interp create a set l "" +} -body { + interp create a lappend l [interp hidden a] a alias bar bar - lappend l [interp aliases a] - lappend l [interp hidden a] + lappend l [interp aliases a] [interp hidden a] a hide bar - lappend l [interp aliases a] - lappend l [interp hidden a] + lappend l [interp aliases a] [interp hidden a] a alias bar {} - lappend l [interp aliases a] - lappend l [interp hidden a] + lappend l [interp aliases a] [interp hidden a] +} -cleanup { interp delete a - set l -} {{} bar {} bar bar {} {}} -test interp-23.2 {testing hiding vs aliases} {unixOrPc} { +} -result {{} bar {} bar bar {} {}} +test interp-23.2 {testing hiding vs aliases: safe interp} -setup { catch {interp delete a} - interp create a -safe set l "" +} -constraints {unixOrPc} -body { + interp create a -safe lappend l [lsort [interp hidden a]] a alias bar bar - lappend l [lsort [interp aliases a]] - lappend l [lsort [interp hidden a]] + lappend l [lsort [interp aliases a]] [lsort [interp hidden a]] a hide bar - lappend l [lsort [interp aliases a]] - lappend l [lsort [interp hidden a]] + lappend l [lsort [interp aliases a]] [lsort [interp hidden a]] a alias bar {} - lappend l [lsort [interp aliases a]] - lappend l [lsort [interp hidden a]] + lappend l [lsort [interp aliases a]] [lsort [interp hidden a]] +} -cleanup { interp delete a - set l -} {{cd encoding exec exit fconfigure file glob load open pwd socket source unload} {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} {cd encoding exec exit fconfigure file glob load open pwd socket source unload} {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} {bar cd encoding exec exit fconfigure file glob load open pwd socket source unload} {::tcl::mathfunc::max ::tcl::mathfunc::min clock} {cd encoding exec exit fconfigure file glob load open pwd socket source unload}} +} -result [list $hidden_cmds {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} $hidden_cmds {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} [lsort [concat $hidden_cmds bar]] {::tcl::mathfunc::max ::tcl::mathfunc::min clock} $hidden_cmds] -test interp-24.1 {result resetting on error} { +test interp-24.1 {result resetting on error} -setup { catch {interp delete a} +} -body { interp create a - proc foo args {error $args} - interp alias a foo {} foo - set l [interp eval a { - set l {} - lappend l [catch {foo 1 2 3} msg] - lappend l $msg - lappend l [catch {foo 3 4 5} msg] - lappend l $msg - set l - }] + interp alias a foo {} apply {args {error $args}} + interp eval a { + lappend l [catch {foo 1 2 3} msg] $msg + lappend l [catch {foo 3 4 5} msg] $msg + } +} -cleanup { interp delete a - rename foo {} - set l -} {1 {1 2 3} 1 {3 4 5}} -test interp-24.2 {result resetting on error} { +} -result {1 {1 2 3} 1 {3 4 5}} +test interp-24.2 {result resetting on error} -setup { catch {interp delete a} +} -body { interp create a -safe - proc foo args {error $args} - interp alias a foo {} foo - set l [interp eval a { - set l {} - lappend l [catch {foo 1 2 3} msg] - lappend l $msg - lappend l [catch {foo 3 4 5} msg] - lappend l $msg - set l - }] + interp alias a foo {} apply {args {error $args}} + interp eval a { + lappend l [catch {foo 1 2 3} msg] $msg + lappend l [catch {foo 3 4 5} msg] $msg + } +} -cleanup { interp delete a - rename foo {} - set l -} {1 {1 2 3} 1 {3 4 5}} -test interp-24.3 {result resetting on error} { +} -result {1 {1 2 3} 1 {3 4 5}} +test interp-24.3 {result resetting on error} -setup { catch {interp delete a} +} -body { interp create a interp create {a b} interp eval a { proc foo args {error $args} } interp alias {a b} foo a foo - set l [interp eval {a b} { - set l {} - lappend l [catch {foo 1 2 3} msg] - lappend l $msg - lappend l [catch {foo 3 4 5} msg] - lappend l $msg - set l - }] + interp eval {a b} { + lappend l [catch {foo 1 2 3} msg] $msg + lappend l [catch {foo 3 4 5} msg] $msg + } +} -cleanup { interp delete a - set l -} {1 {1 2 3} 1 {3 4 5}} -test interp-24.4 {result resetting on error} { +} -result {1 {1 2 3} 1 {3 4 5}} +test interp-24.4 {result resetting on error} -setup { catch {interp delete a} +} -body { interp create a -safe interp create {a b} interp eval a { proc foo args {error $args} } interp alias {a b} foo a foo - set l [interp eval {a b} { - set l {} + interp eval {a b} { lappend l [catch {foo 1 2 3} msg] lappend l $msg lappend l [catch {foo 3 4 5} msg] lappend l $msg - set l - }] + } +} -cleanup { interp delete a - set l -} {1 {1 2 3} 1 {3 4 5}} -test interp-24.5 {result resetting on error} { +} -result {1 {1 2 3} 1 {3 4 5}} +test interp-24.5 {result resetting on error} -setup { catch {interp delete a} catch {interp delete b} +} -body { interp create a interp create b interp eval a { proc foo args {error $args} } interp alias b foo a foo - set l [interp eval b { - set l {} - lappend l [catch {foo 1 2 3} msg] - lappend l $msg - lappend l [catch {foo 3 4 5} msg] - lappend l $msg - set l - }] + interp eval b { + lappend l [catch {foo 1 2 3} msg] $msg + lappend l [catch {foo 3 4 5} msg] $msg + } +} -cleanup { interp delete a - set l -} {1 {1 2 3} 1 {3 4 5}} -test interp-24.6 {result resetting on error} { + interp delete b +} -result {1 {1 2 3} 1 {3 4 5}} +test interp-24.6 {result resetting on error} -setup { catch {interp delete a} catch {interp delete b} +} -body { interp create a -safe interp create b -safe interp eval a { proc foo args {error $args} } interp alias b foo a foo - set l [interp eval b { - set l {} - lappend l [catch {foo 1 2 3} msg] - lappend l $msg - lappend l [catch {foo 3 4 5} msg] - lappend l $msg - set l - }] + interp eval b { + lappend l [catch {foo 1 2 3} msg] $msg + lappend l [catch {foo 3 4 5} msg] $msg + } +} -cleanup { interp delete a - set l -} {1 {1 2 3} 1 {3 4 5}} -test interp-24.7 {result resetting on error} { + interp delete b +} -result {1 {1 2 3} 1 {3 4 5}} +test interp-24.7 {result resetting on error} -setup { catch {interp delete a} + set l {} +} -body { interp create a interp eval a { proc foo args {error $args} } - set l {} - lappend l [catch {interp eval a foo 1 2 3} msg] - lappend l $msg - lappend l [catch {interp eval a foo 3 4 5} msg] - lappend l $msg + lappend l [catch {interp eval a foo 1 2 3} msg] $msg + lappend l [catch {interp eval a foo 3 4 5} msg] $msg +} -cleanup { interp delete a - set l -} {1 {1 2 3} 1 {3 4 5}} -test interp-24.8 {result resetting on error} { +} -result {1 {1 2 3} 1 {3 4 5}} +test interp-24.8 {result resetting on error} -setup { catch {interp delete a} + set l {} +} -body { interp create a -safe interp eval a { proc foo args {error $args} } - set l {} - lappend l [catch {interp eval a foo 1 2 3} msg] - lappend l $msg - lappend l [catch {interp eval a foo 3 4 5} msg] - lappend l $msg + lappend l [catch {interp eval a foo 1 2 3} msg] $msg + lappend l [catch {interp eval a foo 3 4 5} msg] $msg +} -cleanup { interp delete a - set l -} {1 {1 2 3} 1 {3 4 5}} -test interp-24.9 {result resetting on error} { +} -result {1 {1 2 3} 1 {3 4 5}} +test interp-24.9 {result resetting on error} -setup { catch {interp delete a} + set l {} +} -body { interp create a interp create {a b} interp eval {a b} { @@ -1954,16 +1938,15 @@ test interp-24.9 {result resetting on error} { eval interp eval b foo $args } } - set l {} - lappend l [catch {interp eval a foo 1 2 3} msg] - lappend l $msg - lappend l [catch {interp eval a foo 3 4 5} msg] - lappend l $msg + lappend l [catch {interp eval a foo 1 2 3} msg] $msg + lappend l [catch {interp eval a foo 3 4 5} msg] $msg +} -cleanup { interp delete a - set l -} {1 {1 2 3} 1 {3 4 5}} -test interp-24.10 {result resetting on error} { +} -result {1 {1 2 3} 1 {3 4 5}} +test interp-24.10 {result resetting on error} -setup { catch {interp delete a} + set l {} +} -body { interp create a -safe interp create {a b} interp eval {a b} { @@ -1974,16 +1957,14 @@ test interp-24.10 {result resetting on error} { eval interp eval b foo $args } } - set l {} - lappend l [catch {interp eval a foo 1 2 3} msg] - lappend l $msg - lappend l [catch {interp eval a foo 3 4 5} msg] - lappend l $msg + lappend l [catch {interp eval a foo 1 2 3} msg] $msg + lappend l [catch {interp eval a foo 3 4 5} msg] $msg +} -cleanup { interp delete a - set l -} {1 {1 2 3} 1 {3 4 5}} -test interp-24.11 {result resetting on error} { +} -result {1 {1 2 3} 1 {3 4 5}} +test interp-24.11 {result resetting on error} -setup { catch {interp delete a} +} -body { interp create a interp create {a b} interp eval {a b} { @@ -1991,20 +1972,17 @@ test interp-24.11 {result resetting on error} { } interp eval a { proc foo args { - set l {} - lappend l [catch {eval interp eval b foo $args} msg] - lappend l $msg - lappend l [catch {eval interp eval b foo $args} msg] - lappend l $msg - set l + lappend l [catch {eval interp eval b foo $args} msg] $msg + lappend l [catch {eval interp eval b foo $args} msg] $msg } } - set l [interp eval a foo 1 2 3] + interp eval a foo 1 2 3 +} -cleanup { interp delete a - set l -} {1 {1 2 3} 1 {1 2 3}} -test interp-24.12 {result resetting on error} { +} -result {1 {1 2 3} 1 {1 2 3}} +test interp-24.12 {result resetting on error} -setup { catch {interp delete a} +} -body { interp create a -safe interp create {a b} interp eval {a b} { @@ -2012,27 +1990,22 @@ test interp-24.12 {result resetting on error} { } interp eval a { proc foo args { - set l {} - lappend l [catch {eval interp eval b foo $args} msg] - lappend l $msg - lappend l [catch {eval interp eval b foo $args} msg] - lappend l $msg - set l + lappend l [catch {eval interp eval b foo $args} msg] $msg + lappend l [catch {eval interp eval b foo $args} msg] $msg } } - set l [interp eval a foo 1 2 3] + interp eval a foo 1 2 3 +} -cleanup { interp delete a - set l -} {1 {1 2 3} 1 {1 2 3}} +} -result {1 {1 2 3} 1 {1 2 3}} -unset hidden_cmds - -test interp-25.1 {testing aliasing of string commands} { +test interp-25.1 {testing aliasing of string commands} -setup { catch {interp delete a} +} -body { interp create a a alias exec foo ;# Relies on exec being a string command! interp delete a -} "" +} -result "" # # Interps result transmission @@ -3058,7 +3031,7 @@ test interp-31.1 {alias invocation scope} { myNewSet a $value return $a } - catch {unset a} + unset -nocomplain a set result [testMyNewSet "ok"] rename testMyNewSet {} rename mySet {} @@ -3580,7 +3553,7 @@ test interp-36.7 {SlaveBgerror sets error handler of slave [1999035]} -setup { set result } -cleanup { variable result {} - unset result + unset -nocomplain result interp delete slave } -result foo @@ -3593,7 +3566,7 @@ test interp-37.1 {safe interps and min() and max(): Bug 2895741} -setup { lappend result [interp eval a {expr min(5,2,3)*max(7,13,11)}] lappend result [interp eval {a b} {expr min(5,2,3)*max(7,13,11)}] } -cleanup { - unset result + unset -nocomplain result interp delete a } -result {26 26} @@ -3614,7 +3587,7 @@ test interp-38.2 {interp debug env var} -setup { } -body { interp debug a } -cleanup { - unset ::env(TCL_INTERP_DEBUG_FRAME) + unset -nocomplain ::env(TCL_INTERP_DEBUG_FRAME) interp delete a } -result {-frame 1} test interp-38.3 {interp debug wrong args} -body { @@ -3642,6 +3615,7 @@ test interp-38.8 {interp debug basic setup} -body { # cleanup +unset -nocomplain hidden_cmds foreach i [interp slaves] { interp delete $i } |