/* * tclUnixFCmd.c * * This file implements the unix specific portion of file manipulation * subcommands of the "file" command. All filename arguments should * already be translated to native format. * * Copyright (c) 1996-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclUnixFCmd.c,v 1.34 2004/01/29 10:28:23 vincentdarley Exp $ * * Portions of this code were derived from NetBSD source code which has * the following copyright notice: * * Copyright (c) 1988, 1993, 1994 * The Regents of the University of California. All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions * are met: * 1. Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * 2. Redistributions in binary form must reproduce the above copyright * notice, this list of conditions and the following disclaimer in the * documentation and/or other materials provided with the distribution. * 3. All advertising materials mentioning features or use of this software * must display the following acknowledgement: * This product includes software developed by the University of * California, Berkeley and its contributors. * 4. Neither the name of the University nor the names of its contributors * may be used to endorse or promote products derived from this software * without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF * SUCH DAMAGE. */ #include "tclInt.h" #include "tclPort.h" #include #include #ifndef HAVE_ST_BLKSIZE #ifndef NO_FSTATFS #include #endif #endif /* * The following constants specify the type of callback when * TraverseUnixTree() calls the traverseProc() */ #define DOTREE_PRED 1 /* pre-order directory */ #define DOTREE_POSTD 2 /* post-order directory */ #define DOTREE_F 3 /* regular file */ /* * Callbacks for file attributes code. */ static int GetGroupAttribute _ANSI_ARGS_((Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr)); static int GetOwnerAttribute _ANSI_ARGS_((Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr)); static int GetPermissionsAttribute _ANSI_ARGS_(( Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr)); static int SetGroupAttribute _ANSI_ARGS_((Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr)); static int SetOwnerAttribute _ANSI_ARGS_((Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr)); static int SetPermissionsAttribute _ANSI_ARGS_(( Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr)); static int GetModeFromPermString _ANSI_ARGS_(( Tcl_Interp *interp, char *modeStringPtr, mode_t *modePtr)); #if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) static int GetReadOnlyAttribute _ANSI_ARGS_((Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr)); static int SetReadOnlyAttribute _ANSI_ARGS_((Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr)); #endif /* * Prototype for the TraverseUnixTree callback function. */ typedef int (TraversalProc) _ANSI_ARGS_((Tcl_DString *srcPtr, Tcl_DString *dstPtr, CONST Tcl_StatBuf *statBufPtr, int type, Tcl_DString *errorPtr)); /* * Constants and variables necessary for file attributes subcommand. * * IMPORTANT: The permissions attribute is assumed to be the third * item (i.e. to be indexed with '2' in arrays) in code in tclIOUtil.c * and possibly elsewhere in Tcl's core. */ enum { UNIX_GROUP_ATTRIBUTE, UNIX_OWNER_ATTRIBUTE, UNIX_PERMISSIONS_ATTRIBUTE, #if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) UNIX_READONLY_ATTRIBUTE, #endif #ifdef MAC_OSX_TCL MACOSX_CREATOR_ATTRIBUTE, MACOSX_TYPE_ATTRIBUTE, MACOSX_HIDDEN_ATTRIBUTE, MACOSX_RSRCLENGTH_ATTRIBUTE, #endif }; CONST char *tclpFileAttrStrings[] = { "-group", "-owner", "-permissions", #if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) "-readonly", #endif #ifdef MAC_OSX_TCL "-creator", "-type", "-hidden", "-rsrclength", #endif (char *) NULL }; CONST TclFileAttrProcs tclpFileAttrProcs[] = { {GetGroupAttribute, SetGroupAttribute}, {GetOwnerAttribute, SetOwnerAttribute}, {GetPermissionsAttribute, SetPermissionsAttribute}, #if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) {GetReadOnlyAttribute, SetReadOnlyAttribute}, #endif #ifdef MAC_OSX_TCL {TclMacOSXGetFileAttribute, TclMacOSXSetFileAttribute}, {TclMacOSXGetFileAttribute, TclMacOSXSetFileAttribute}, {TclMacOSXGetFileAttribute, TclMacOSXSetFileAttribute}, {TclMacOSXGetFileAttribute, TclMacOSXSetFileAttribute}, #endif }; /* * Declarations for local procedures defined in this file: */ static int CopyFileAtts _ANSI_ARGS_((CONST char *src, CONST char *dst, CONST Tcl_StatBuf *statBufPtr)); static int DoCopyFile _ANSI_ARGS_((CONST char *srcPtr, CONST char *dstPtr)); static int DoCreateDirectory _ANSI_ARGS_((CONST char *pathPtr)); static int DoRemoveDirectory _ANSI_ARGS_((Tcl_DString *pathPtr, int recursive, Tcl_DString *errorPtr)); static int DoRenameFile _ANSI_ARGS_((CONST char *src, CONST char *dst)); static int TraversalCopy _ANSI_ARGS_((Tcl_DString *srcPtr, Tcl_DString *dstPtr, CONST Tcl_StatBuf *statBufPtr, int type, Tcl_DString *errorPtr)); static int TraversalDelete _ANSI_ARGS_((Tcl_DString *srcPtr, Tcl_DString *dstPtr, CONST Tcl_StatBuf *statBufPtr, int type, Tcl_DString *errorPtr)); static int TraverseUnixTree _ANSI_ARGS_(( TraversalProc *traversalProc, Tcl_DString *sourcePtr, Tcl_DString *destPtr, Tcl_DString *errorPtr)); #ifdef PURIFY /* * realpath and purify don't mix happily. It has been noted that realpath * should not be used with purify because of bogus warnings, but just * memset'ing the resolved path will squelch those. This assumes we are * passing the standard MAXPATHLEN size resolved arg. */ static char * Realpath _ANSI_ARGS_((CONST char *path, char *resolved)); char * Realpath(path, resolved) CONST char *path; char *resolved; { memset(resolved, 0, MAXPATHLEN); return realpath(path, resolved); } #else #define Realpath realpath #endif /* *--------------------------------------------------------------------------- * * TclpObjRenameFile, DoRenameFile -- * * Changes the name of an existing file or directory, from src to dst. * If src and dst refer to the same file or directory, does nothing * and returns success. Otherwise if dst already exists, it will be * deleted and replaced by src subject to the following conditions: * If src is a directory, dst may be an empty directory. * If src is a file, dst may be a file. * In any other situation where dst already exists, the rename will * fail. * * Results: * If the directory was successfully created, returns TCL_OK. * Otherwise the return value is TCL_ERROR and errno is set to * indicate the error. Some possible values for errno are: * * EACCES: src or dst parent directory can't be read and/or written. * EEXIST: dst is a non-empty directory. * EINVAL: src is a root directory or dst is a subdirectory of src. * EISDIR: dst is a directory, but src is not. * ENOENT: src doesn't exist, or src or dst is "". * ENOTDIR: src is a directory, but dst is not. * EXDEV: src and dst are on different filesystems. * * Side effects: * The implementation of rename may allow cross-filesystem renames, * but the caller should be prepared to emulate it with copy and * delete if errno is EXDEV. * *--------------------------------------------------------------------------- */ int TclpObjRenameFile(srcPathPtr, destPathPtr) Tcl_Obj *srcPathPtr; Tcl_Obj *destPathPtr; { return DoRenameFile(Tcl_FSGetNativePath(srcPathPtr), Tcl_FSGetNativePath(destPathPtr)); } static int DoRenameFile(src, dst) CONST char *src; /* Pathname of file or dir to be renamed * (native). */ CONST char *dst; /* New pathname of file or directory * (native). */ { if (rename(src, dst) == 0) { /* INTL: Native. */ return TCL_OK; } if (errno == ENOTEMPTY) { errno = EEXIST; } /* * IRIX returns EIO when you attept to move a directory into * itself. We just map EIO to EINVAL get the right message on SGI. * Most platforms don't return EIO except in really strange cases. */ if (errno == EIO) { errno = EINVAL; } #ifndef NO_REALPATH /* * SunOS 4.1.4 reports overwriting a non-empty directory with a * directory as EINVAL instead of EEXIST (first rule out the correct * EINVAL result code for moving a directory into itself). Must be * conditionally compiled because realpath() not defined on all systems. */ if (errno == EINVAL) { char srcPath[MAXPATHLEN], dstPath[MAXPATHLEN]; DIR *dirPtr; Tcl_DirEntry *dirEntPtr; if ((Realpath((char *) src, srcPath) != NULL) /* INTL: Native. */ && (Realpath((char *) dst, dstPath) != NULL) /* INTL: Native. */ && (strncmp(srcPath, dstPath, strlen(srcPath)) != 0)) { dirPtr = opendir(dst); /* INTL: Native. */ if (dirPtr != NULL) { while (1) { dirEntPtr = TclOSreaddir(dirPtr); /* INTL: Native. */ if (dirEntPtr == NULL) { break; } if ((strcmp(dirEntPtr->d_name, ".") != 0) && (strcmp(dirEntPtr->d_name, "..") != 0)) { errno = EEXIST; closedir(dirPtr); return TCL_ERROR; } } closedir(dirPtr); } } errno = EINVAL; } #endif /* !NO_REALPATH */ if (strcmp(src, "/") == 0) { /* * Alpha reports renaming / as EBUSY and Linux reports it as EACCES, * instead of EINVAL. */ errno = EINVAL; } /* * DEC Alpha OSF1 V3.0 returns EACCES when attempting to move a * file across filesystems and the parent directory of that file is * not writable. Most other systems return EXDEV. Does nothing to * correct this behavior. */ return TCL_ERROR; } /* *--------------------------------------------------------------------------- * * TclpObjCopyFile, DoCopyFile -- * * Copy a single file (not a directory). If dst already exists and * is not a directory, it is removed. * * Results: * If the file was successfully copied, returns TCL_OK. Otherwise * the return value is TCL_ERROR and errno is set to indicate the * error. Some possible values for errno are: * * EACCES: src or dst parent directory can't be read and/or written. * EISDIR: src or dst is a directory. * ENOENT: src doesn't exist. src or dst is "". * * Side effects: * This procedure will also copy symbolic links, block, and * character devices, and fifos. For symbolic links, the links * themselves will be copied and not what they point to. For the * other special file types, the directory entry will be copied and * not the contents of the device that it refers to. * *--------------------------------------------------------------------------- */ int TclpObjCopyFile(srcPathPtr, destPathPtr) Tcl_Obj *srcPathPtr; Tcl_Obj *destPathPtr; { return DoCopyFile(Tcl_FSGetNativePath(srcPathPtr), Tcl_FSGetNativePath(destPathPtr)); } static int DoCopyFile(src, dst) CONST char *src; /* Pathname of file to be copied (native). */ CONST char *dst; /* Pathname of file to copy to (native). */ { Tcl_StatBuf srcStatBuf, dstStatBuf; /* * Have to do a stat() to determine the filetype. */ if (TclOSlstat(src, &srcStatBuf) != 0) { /* INTL: Native. */ return TCL_ERROR; } if (S_ISDIR(srcStatBuf.st_mode)) { errno = EISDIR; return TCL_ERROR; } /* * symlink, and some of the other calls will fail if the target * exists, so we remove it first */ if (TclOSlstat(dst, &dstStatBuf) == 0) { /* INTL: Native. */ if (S_ISDIR(dstStatBuf.st_mode)) { errno = EISDIR; return TCL_ERROR; } } if (unlink(dst) != 0) { /* INTL: Native. */ if (errno != ENOENT) { return TCL_ERROR; } } switch ((int) (srcStatBuf.st_mode & S_IFMT)) { #ifndef DJGPP case S_IFLNK: { char link[MAXPATHLEN]; int length; length = readlink(src, link, sizeof(link)); /* INTL: Native. */ if (length == -1) { return TCL_ERROR; } link[length] = '\0'; if (symlink(link, dst) < 0) { /* INTL: Native. */ return TCL_ERROR; } break; } #endif case S_IFBLK: case S_IFCHR: { if (mknod(dst, srcStatBuf.st_mode, /* INTL: Native. */ srcStatBuf.st_rdev) < 0) { return TCL_ERROR; } return CopyFileAtts(src, dst, &srcStatBuf); } case S_IFIFO: { if (mkfifo(dst, srcStatBuf.st_mode) < 0) { /* INTL: Native. */ return TCL_ERROR; } return CopyFileAtts(src, dst, &srcStatBuf); } default: { return TclUnixCopyFile(src, dst, &srcStatBuf, 0); } } return TCL_OK; } /* *---------------------------------------------------------------------- * * TclUnixCopyFile - * * Helper function for TclpCopyFile. Copies one regular file, * using read() and write(). * * Results: * A standard Tcl result. * * Side effects: * A file is copied. Dst will be overwritten if it exists. * *---------------------------------------------------------------------- */ int TclUnixCopyFile(src, dst, statBufPtr, dontCopyAtts) CONST char *src; /* Pathname of file to copy (native). */ CONST char *dst; /* Pathname of file to create/overwrite * (native). */ CONST Tcl_StatBuf *statBufPtr; /* Used to determine mode and blocksize. */ int dontCopyAtts; /* if flag set, don't copy attributes. */ { int srcFd; int dstFd; u_int blockSize; /* Optimal I/O blocksize for filesystem */ char *buffer; /* Data buffer for copy */ size_t nread; #ifdef DJGPP #define BINMODE |O_BINARY #else #define BINMODE #endif if ((srcFd = TclOSopen(src, O_RDONLY BINMODE, 0)) < 0) { /* INTL: Native. */ return TCL_ERROR; } dstFd = TclOSopen(dst, O_CREAT|O_TRUNC|O_WRONLY BINMODE, /* INTL: Native. */ statBufPtr->st_mode); if (dstFd < 0) { close(srcFd); return TCL_ERROR; } #ifdef HAVE_ST_BLKSIZE blockSize = statBufPtr->st_blksize; #else #ifndef NO_FSTATFS { struct statfs fs; if (fstatfs(srcFd, &fs, sizeof(fs), 0) == 0) { blockSize = fs.f_bsize; } else { blockSize = 4096; } } #else blockSize = 4096; #endif #endif buffer = ckalloc(blockSize); while (1) { nread = read(srcFd, buffer, blockSize); if ((nread == -1) || (nread == 0)) { break; } if (write(dstFd, buffer, nread) != nread) { nread = (size_t) -1; break; } } ckfree(buffer); close(srcFd); if ((close(dstFd) != 0) || (nread == -1)) { unlink(dst); /* INTL: Native. */ return TCL_ERROR; } if (!dontCopyAtts && CopyFileAtts(src, dst, statBufPtr) == TCL_ERROR) { /* * The copy succeeded, but setting the permissions failed, so be in * a consistent state, we remove the file that was created by the * copy. */ unlink(dst); /* INTL: Native. */ return TCL_ERROR; } return TCL_OK; } /* *--------------------------------------------------------------------------- * * TclpObjDeleteFile, TclpDeleteFile -- * * Removes a single file (not a directory). * * Results: * If the file was successfully deleted, returns TCL_OK. Otherwise * the return value is TCL_ERROR and errno is set to indicate the * error. Some possible values for errno are: * * EACCES: a parent directory can't be read and/or written. * EISDIR: path is a directory. * ENOENT: path doesn't exist or is "". * * Side effects: * The file is deleted, even if it is read-only. * *--------------------------------------------------------------------------- */ int TclpObjDeleteFile(pathPtr) Tcl_Obj *pathPtr; { return TclpDeleteFile(Tcl_FSGetNativePath(pathPtr)); } int TclpDeleteFile(path) CONST char *path; /* Pathname of file to be removed (native). */ { if (unlink(path) != 0) { /* INTL: Native. */ return TCL_ERROR; } return TCL_OK; } /* *--------------------------------------------------------------------------- * * TclpCreateDirectory, DoCreateDirectory -- * * Creates the specified directory. All parent directories of the * specified directory must already exist. The directory is * automatically created with permissions so that user can access * the new directory and create new files or subdirectories in it. * * Results: * If the directory was successfully created, returns TCL_OK. * Otherwise the return value is TCL_ERROR and errno is set to * indicate the error. Some possible values for errno are: * * EACCES: a parent directory can't be read and/or written. * EEXIST: path already exists. * ENOENT: a parent directory doesn't exist. * * Side effects: * A directory is created with the current umask, except that * permission for u+rwx will always be added. * *--------------------------------------------------------------------------- */ int TclpObjCreateDirectory(pathPtr) Tcl_Obj *pathPtr; { return DoCreateDirectory(Tcl_FSGetNativePath(pathPtr)); } static int DoCreateDirectory(path) CONST char *path; /* Pathname of directory to create (native). */ { mode_t mode; mode = umask(0); umask(mode); /* * umask return value is actually the inverse of the permissions. */ mode = (0777 & ~mode) | S_IRUSR | S_IWUSR | S_IXUSR; if (mkdir(path, mode) != 0) { /* INTL: Native. */ return TCL_ERROR; } return TCL_OK; } /* *--------------------------------------------------------------------------- * * TclpObjCopyDirectory -- * * Recursively copies a directory. The target directory dst must * not already exist. Note that this function does not merge two * directory hierarchies, even if the target directory is an an * empty directory. * * Results: * If the directory was successfully copied, returns TCL_OK. * Otherwise the return value is TCL_ERROR, errno is set to indicate * the error, and the pathname of the file that caused the error * is stored in errorPtr. See TclpObjCreateDirectory and * TclpObjCopyFile for a description of possible values for errno. * * Side effects: * An exact copy of the directory hierarchy src will be created * with the name dst. If an error occurs, the error will * be returned immediately, and remaining files will not be * processed. * *--------------------------------------------------------------------------- */ int TclpObjCopyDirectory(srcPathPtr, destPathPtr, errorPtr) Tcl_Obj *srcPathPtr; Tcl_Obj *destPathPtr; Tcl_Obj **errorPtr; { Tcl_DString ds; Tcl_DString srcString, dstString; int ret; Tcl_Obj *transPtr; transPtr = Tcl_FSGetTranslatedPath(NULL,srcPathPtr); Tcl_UtfToExternalDString(NULL, (transPtr != NULL ? Tcl_GetString(transPtr) : NULL), -1, &srcString); if (transPtr != NULL) { Tcl_DecrRefCount(transPtr); } transPtr = Tcl_FSGetTranslatedPath(NULL,destPathPtr); Tcl_UtfToExternalDString(NULL, (transPtr != NULL ? Tcl_GetString(transPtr) : NULL), -1, &dstString); if (transPtr != NULL) { Tcl_DecrRefCount(transPtr); } ret = TraverseUnixTree(TraversalCopy, &srcString, &dstString, &ds); Tcl_DStringFree(&srcString); Tcl_DStringFree(&dstString); if (ret != TCL_OK) { *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); Tcl_DStringFree(&ds); Tcl_IncrRefCount(*errorPtr); } return ret; } /* *--------------------------------------------------------------------------- * * TclpRemoveDirectory, DoRemoveDirectory -- * * Removes directory (and its contents, if the recursive flag is set). * * Results: * If the directory was successfully removed, returns TCL_OK. * Otherwise the return value is TCL_ERROR, errno is set to indicate * the error, and the pathname of the file that caused the error * is stored in errorPtr. Some possible values for errno are: * * EACCES: path directory can't be read and/or written. * EEXIST: path is a non-empty directory. * EINVAL: path is a root directory. * ENOENT: path doesn't exist or is "". * ENOTDIR: path is not a directory. * * Side effects: * Directory removed. If an error occurs, the error will be returned * immediately, and remaining files will not be deleted. * *--------------------------------------------------------------------------- */ int TclpObjRemoveDirectory(pathPtr, recursive, errorPtr) Tcl_Obj *pathPtr; int recursive; Tcl_Obj **errorPtr; { Tcl_DString ds; Tcl_DString pathString; int ret; Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); Tcl_UtfToExternalDString(NULL, (transPtr != NULL ? Tcl_GetString(transPtr) : NULL), -1, &pathString); if (transPtr != NULL) { Tcl_DecrRefCount(transPtr); } ret = DoRemoveDirectory(&pathString, recursive, &ds); Tcl_DStringFree(&pathString); if (ret != TCL_OK) { *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); Tcl_DStringFree(&ds); Tcl_IncrRefCount(*errorPtr); } return ret; } static int DoRemoveDirectory(pathPtr, recursive, errorPtr) Tcl_DString *pathPtr; /* Pathname of directory to be removed * (native). */ int recursive; /* If non-zero, removes directories that * are nonempty. Otherwise, will only remove * empty directories. */ Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free * DString filled with UTF-8 name of file * causing error. */ { CONST char *path; mode_t oldPerm = 0; int result; path = Tcl_DStringValue(pathPtr); if (recursive != 0) { /* We should try to change permissions so this can be deleted */ Tcl_StatBuf statBuf; int newPerm; if (TclOSstat(path, &statBuf) == 0) { oldPerm = (mode_t) (statBuf.st_mode & 0x00007FFF); } newPerm = oldPerm | (64+128+256); chmod(path, (mode_t) newPerm); } if (rmdir(path) == 0) { /* INTL: Native. */ return TCL_OK; } if (errno == ENOTEMPTY) { errno = EEXIST; } result = TCL_OK; if ((errno != EEXIST) || (recursive == 0)) { if (errorPtr != NULL) { Tcl_ExternalToUtfDString(NULL, path, -1, errorPtr); } result = TCL_ERROR; } /* * The directory is nonempty, but the recursive flag has been * specified, so we recursively remove all the files in the directory. */ if (result == TCL_OK) { result = TraverseUnixTree(TraversalDelete, pathPtr, NULL, errorPtr); } if ((result != TCL_OK) && (recursive != 0)) { /* Try to restore permissions */ chmod(path, oldPerm); } return result; } /* *--------------------------------------------------------------------------- * * TraverseUnixTree -- * * Traverse directory tree specified by sourcePtr, calling the function * traverseProc for each file and directory encountered. If destPtr * is non-null, each of name in the sourcePtr directory is appended to * the directory specified by destPtr and passed as the second argument * to traverseProc() . * * Results: * Standard Tcl result. * * Side effects: * None caused by TraverseUnixTree, however the user specified * traverseProc() may change state. If an error occurs, the error will * be returned immediately, and remaining files will not be processed. * *--------------------------------------------------------------------------- */ static int TraverseUnixTree(traverseProc, sourcePtr, targetPtr, errorPtr) TraversalProc *traverseProc;/* Function to call for every file and * directory in source hierarchy. */ Tcl_DString *sourcePtr; /* Pathname of source directory to be * traversed (native). */ Tcl_DString *targetPtr; /* Pathname of directory to traverse in * parallel with source directory (native). */ Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free * DString filled with UTF-8 name of file * causing error. */ { Tcl_StatBuf statBuf; CONST char *source, *errfile; int result, sourceLen; int targetLen; Tcl_DirEntry *dirEntPtr; DIR *dirPtr; errfile = NULL; result = TCL_OK; targetLen = 0; /* lint. */ source = Tcl_DStringValue(sourcePtr); if (TclOSlstat(source, &statBuf) != 0) { /* INTL: Native. */ errfile = source; goto end; } if (!S_ISDIR(statBuf.st_mode)) { /* * Process the regular file */ return (*traverseProc)(sourcePtr, targetPtr, &statBuf, DOTREE_F, errorPtr); } dirPtr = opendir(source); /* INTL: Native. */ if (dirPtr == NULL) { /* * Can't read directory */ errfile = source; goto end; } result = (*traverseProc)(sourcePtr, targetPtr, &statBuf, DOTREE_PRED, errorPtr); if (result != TCL_OK) { closedir(dirPtr); return result; } Tcl_DStringAppend(sourcePtr, "/", 1); sourceLen = Tcl_DStringLength(sourcePtr); if (targetPtr != NULL) { Tcl_DStringAppend(targetPtr, "/", 1); targetLen = Tcl_DStringLength(targetPtr); } while ((dirEntPtr = TclOSreaddir(dirPtr)) != NULL) { /* INTL: Native. */ if ((dirEntPtr->d_name[0] == '.') && ((dirEntPtr->d_name[1] == '\0') || (strcmp(dirEntPtr->d_name, "..") == 0))) { continue; } /* * Append name after slash, and recurse on the file. */ Tcl_DStringAppend(sourcePtr, dirEntPtr->d_name, -1); if (targetPtr != NULL) { Tcl_DStringAppend(targetPtr, dirEntPtr->d_name, -1); } result = TraverseUnixTree(traverseProc, sourcePtr, targetPtr, errorPtr); if (result != TCL_OK) { break; } /* * Remove name after slash. */ Tcl_DStringSetLength(sourcePtr, sourceLen); if (targetPtr != NULL) { Tcl_DStringSetLength(targetPtr, targetLen); } } closedir(dirPtr); /* * Strip off the trailing slash we added */ Tcl_DStringSetLength(sourcePtr, sourceLen - 1); if (targetPtr != NULL) { Tcl_DStringSetLength(targetPtr, targetLen - 1); } if (result == TCL_OK) { /* * Call traverseProc() on a directory after visiting all the * files in that directory. */ result = (*traverseProc)(sourcePtr, targetPtr, &statBuf, DOTREE_POSTD, errorPtr); } end: if (errfile != NULL) { if (errorPtr != NULL) { Tcl_ExternalToUtfDString(NULL, errfile, -1, errorPtr); } result = TCL_ERROR; } return result; } /* *---------------------------------------------------------------------- * * TraversalCopy * * Called from TraverseUnixTree in order to execute a recursive copy * of a directory. * * Results: * Standard Tcl result. * * Side effects: * The file or directory src may be copied to dst, depending on * the value of type. * *---------------------------------------------------------------------- */ static int TraversalCopy(srcPtr, dstPtr, statBufPtr, type, errorPtr) Tcl_DString *srcPtr; /* Source pathname to copy (native). */ Tcl_DString *dstPtr; /* Destination pathname of copy (native). */ CONST Tcl_StatBuf *statBufPtr; /* Stat info for file specified by srcPtr. */ int type; /* Reason for call - see TraverseUnixTree(). */ Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free * DString filled with UTF-8 name of file * causing error. */ { switch (type) { case DOTREE_F: if (DoCopyFile(Tcl_DStringValue(srcPtr), Tcl_DStringValue(dstPtr)) == TCL_OK) { return TCL_OK; } break; case DOTREE_PRED: if (DoCreateDirectory(Tcl_DStringValue(dstPtr)) == TCL_OK) { return TCL_OK; } break; case DOTREE_POSTD: if (CopyFileAtts(Tcl_DStringValue(srcPtr), Tcl_DStringValue(dstPtr), statBufPtr) == TCL_OK) { return TCL_OK; } break; } /* * There shouldn't be a problem with src, because we already checked it * to get here. */ if (errorPtr != NULL) { Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(dstPtr), Tcl_DStringLength(dstPtr), errorPtr); } return TCL_ERROR; } /* *--------------------------------------------------------------------------- * * TraversalDelete -- * * Called by procedure TraverseUnixTree for every file and directory * that it encounters in a directory hierarchy. This procedure unlinks * files, and removes directories after all the containing files * have been processed. * * Results: * Standard Tcl result. * * Side effects: * Files or directory specified by src will be deleted. * *---------------------------------------------------------------------- */ static int TraversalDelete(srcPtr, ignore, statBufPtr, type, errorPtr) Tcl_DString *srcPtr; /* Source pathname (native). */ Tcl_DString *ignore; /* Destination pathname (not used). */ CONST Tcl_StatBuf *statBufPtr; /* Stat info for file specified by srcPtr. */ int type; /* Reason for call - see TraverseUnixTree(). */ Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free * DString filled with UTF-8 name of file * causing error. */ { switch (type) { case DOTREE_F: { if (TclpDeleteFile(Tcl_DStringValue(srcPtr)) == 0) { return TCL_OK; } break; } case DOTREE_PRED: { return TCL_OK; } case DOTREE_POSTD: { if (DoRemoveDirectory(srcPtr, 0, NULL) == 0) { return TCL_OK; } break; } } if (errorPtr != NULL) { Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(srcPtr), Tcl_DStringLength(srcPtr), errorPtr); } return TCL_ERROR; } /* *--------------------------------------------------------------------------- * * CopyFileAtts -- * * Copy the file attributes such as owner, group, permissions, * and modification date from one file to another. * * Results: * Standard Tcl result. * * Side effects: * user id, group id, permission bits, last modification time, and * last access time are updated in the new file to reflect the * old file. * *--------------------------------------------------------------------------- */ static int CopyFileAtts(src, dst, statBufPtr) CONST char *src; /* Path name of source file (native). */ CONST char *dst; /* Path name of target file (native). */ CONST Tcl_StatBuf *statBufPtr; /* Stat info for source file */ { struct utimbuf tval; mode_t newMode; newMode = statBufPtr->st_mode & (S_ISUID | S_ISGID | S_IRWXU | S_IRWXG | S_IRWXO); /* * Note that if you copy a setuid file that is owned by someone * else, and you are not root, then the copy will be setuid to you. * The most correct implementation would probably be to have the * copy not setuid to anyone if the original file was owned by * someone else, but this corner case isn't currently handled. * It would require another lstat(), or getuid(). */ if (chmod(dst, newMode)) { /* INTL: Native. */ newMode &= ~(S_ISUID | S_ISGID); if (chmod(dst, newMode)) { /* INTL: Native. */ return TCL_ERROR; } } tval.actime = statBufPtr->st_atime; tval.modtime = statBufPtr->st_mtime; if (utime(dst, &tval)) { /* INTL: Native. */ return TCL_ERROR; } #ifdef MAC_OSX_TCL TclMacOSXCopyFileAttributes(src, dst, statBufPtr); #endif return TCL_OK; } /* *---------------------------------------------------------------------- * * GetGroupAttribute * * Gets the group attribute of a file. * * Results: * Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr * if there is no error. * * Side effects: * A new object is allocated. * *---------------------------------------------------------------------- */ static int GetGroupAttribute(interp, objIndex, fileName, attributePtrPtr) Tcl_Interp *interp; /* The interp we are using for errors. */ int objIndex; /* The index of the attribute. */ Tcl_Obj *fileName; /* The name of the file (UTF-8). */ Tcl_Obj **attributePtrPtr; /* A pointer to return the object with. */ { Tcl_StatBuf statBuf; struct group *groupPtr; int result; result = TclpObjStat(fileName, &statBuf); if (result != 0) { Tcl_AppendResult(interp, "could not read \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } groupPtr = getgrgid(statBuf.st_gid); /* INTL: Native. */ if (groupPtr == NULL) { *attributePtrPtr = Tcl_NewIntObj((int) statBuf.st_gid); } else { Tcl_DString ds; CONST char *utf; utf = Tcl_ExternalToUtfDString(NULL, groupPtr->gr_name, -1, &ds); *attributePtrPtr = Tcl_NewStringObj(utf, -1); Tcl_DStringFree(&ds); } endgrent(); return TCL_OK; } /* *---------------------------------------------------------------------- * * GetOwnerAttribute * * Gets the owner attribute of a file. * * Results: * Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr * if there is no error. * * Side effects: * A new object is allocated. * *---------------------------------------------------------------------- */ static int GetOwnerAttribute(interp, objIndex, fileName, attributePtrPtr) Tcl_Interp *interp; /* The interp we are using for errors. */ int objIndex; /* The index of the attribute. */ Tcl_Obj *fileName; /* The name of the file (UTF-8). */ Tcl_Obj **attributePtrPtr; /* A pointer to return the object with. */ { Tcl_StatBuf statBuf; struct passwd *pwPtr; int result; result = TclpObjStat(fileName, &statBuf); if (result != 0) { Tcl_AppendResult(interp, "could not read \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } pwPtr = getpwuid(statBuf.st_uid); /* INTL: Native. */ if (pwPtr == NULL) { *attributePtrPtr = Tcl_NewIntObj((int) statBuf.st_uid); } else { Tcl_DString ds; CONST char *utf; utf = Tcl_ExternalToUtfDString(NULL, pwPtr->pw_name, -1, &ds); *attributePtrPtr = Tcl_NewStringObj(utf, Tcl_DStringLength(&ds)); Tcl_DStringFree(&ds); } endpwent(); return TCL_OK; } /* *---------------------------------------------------------------------- * * GetPermissionsAttribute * * Gets the group attribute of a file. * * Results: * Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr * if there is no error. The object will have ref count 0. * * Side effects: * A new object is allocated. * *---------------------------------------------------------------------- */ static int GetPermissionsAttribute(interp, objIndex, fileName, attributePtrPtr) Tcl_Interp *interp; /* The interp we are using for errors. */ int objIndex; /* The index of the attribute. */ Tcl_Obj *fileName; /* The name of the file (UTF-8). */ Tcl_Obj **attributePtrPtr; /* A pointer to return the object with. */ { Tcl_StatBuf statBuf; char returnString[7]; int result; result = TclpObjStat(fileName, &statBuf); if (result != 0) { Tcl_AppendResult(interp, "could not read \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } sprintf(returnString, "%0#5lo", (long) (statBuf.st_mode & 0x00007FFF)); *attributePtrPtr = Tcl_NewStringObj(returnString, -1); return TCL_OK; } /* *--------------------------------------------------------------------------- * * SetGroupAttribute -- * * Sets the group of the file to the specified group. * * Results: * Standard TCL result. * * Side effects: * As above. * *--------------------------------------------------------------------------- */ static int SetGroupAttribute(interp, objIndex, fileName, attributePtr) Tcl_Interp *interp; /* The interp for error reporting. */ int objIndex; /* The index of the attribute. */ Tcl_Obj *fileName; /* The name of the file (UTF-8). */ Tcl_Obj *attributePtr; /* New group for file. */ { long gid; int result; CONST char *native; if (Tcl_GetLongFromObj(NULL, attributePtr, &gid) != TCL_OK) { Tcl_DString ds; struct group *groupPtr; CONST char *string; int length; string = Tcl_GetStringFromObj(attributePtr, &length); native = Tcl_UtfToExternalDString(NULL, string, length, &ds); groupPtr = getgrnam(native); /* INTL: Native. */ Tcl_DStringFree(&ds); if (groupPtr == NULL) { endgrent(); Tcl_AppendResult(interp, "could not set group for file \"", Tcl_GetString(fileName), "\": group \"", string, "\" does not exist", (char *) NULL); return TCL_ERROR; } gid = groupPtr->gr_gid; } native = Tcl_FSGetNativePath(fileName); result = chown(native, (uid_t) -1, (gid_t) gid); /* INTL: Native. */ endgrent(); if (result != 0) { Tcl_AppendResult(interp, "could not set group for file \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } return TCL_OK; } /* *--------------------------------------------------------------------------- * * SetOwnerAttribute -- * * Sets the owner of the file to the specified owner. * * Results: * Standard TCL result. * * Side effects: * As above. * *--------------------------------------------------------------------------- */ static int SetOwnerAttribute(interp, objIndex, fileName, attributePtr) Tcl_Interp *interp; /* The interp for error reporting. */ int objIndex; /* The index of the attribute. */ Tcl_Obj *fileName; /* The name of the file (UTF-8). */ Tcl_Obj *attributePtr; /* New owner for file. */ { long uid; int result; CONST char *native; if (Tcl_GetLongFromObj(NULL, attributePtr, &uid) != TCL_OK) { Tcl_DString ds; struct passwd *pwPtr; CONST char *string; int length; string = Tcl_GetStringFromObj(attributePtr, &length); native = Tcl_UtfToExternalDString(NULL, string, length, &ds); pwPtr = getpwnam(native); /* INTL: Native. */ Tcl_DStringFree(&ds); if (pwPtr == NULL) { Tcl_AppendResult(interp, "could not set owner for file \"", Tcl_GetString(fileName), "\": user \"", string, "\" does not exist", (char *) NULL); return TCL_ERROR; } uid = pwPtr->pw_uid; } native = Tcl_FSGetNativePath(fileName); result = chown(native, (uid_t) uid, (gid_t) -1); /* INTL: Native. */ if (result != 0) { Tcl_AppendResult(interp, "could not set owner for file \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } return TCL_OK; } /* *--------------------------------------------------------------------------- * * SetPermissionsAttribute * * Sets the file to the given permission. * * Results: * Standard TCL result. * * Side effects: * The permission of the file is changed. * *--------------------------------------------------------------------------- */ static int SetPermissionsAttribute(interp, objIndex, fileName, attributePtr) Tcl_Interp *interp; /* The interp we are using for errors. */ int objIndex; /* The index of the attribute. */ Tcl_Obj *fileName; /* The name of the file (UTF-8). */ Tcl_Obj *attributePtr; /* The attribute to set. */ { long mode; mode_t newMode; int result; CONST char *native; /* * First try if the string is a number */ if (Tcl_GetLongFromObj(NULL, attributePtr, &mode) == TCL_OK) { newMode = (mode_t) (mode & 0x00007FFF); } else { Tcl_StatBuf buf; char *modeStringPtr = Tcl_GetString(attributePtr); /* * Try the forms "rwxrwxrwx" and "ugo=rwx" * * We get the current mode of the file, in order to allow for * ug+-=rwx style chmod strings. */ result = TclpObjStat(fileName, &buf); if (result != 0) { Tcl_AppendResult(interp, "could not read \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } newMode = (mode_t) (buf.st_mode & 0x00007FFF); if (GetModeFromPermString(NULL, modeStringPtr, &newMode) != TCL_OK) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "unknown permission string format \"", modeStringPtr, "\"", (char *) NULL); return TCL_ERROR; } } native = Tcl_FSGetNativePath(fileName); result = chmod(native, newMode); /* INTL: Native. */ if (result != 0) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "could not set permissions for file \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } return TCL_OK; } /* *--------------------------------------------------------------------------- * * TclpObjListVolumes -- * * Lists the currently mounted volumes, which on UNIX is just /. * * Results: * The list of volumes. * * Side effects: * None. * *--------------------------------------------------------------------------- */ Tcl_Obj* TclpObjListVolumes(void) { Tcl_Obj *resultPtr = Tcl_NewStringObj("/",1); Tcl_IncrRefCount(resultPtr); return resultPtr; } /* *---------------------------------------------------------------------- * * GetModeFromPermString -- * * This procedure is invoked to process the "file permissions" * Tcl command, to check for a "rwxrwxrwx" or "ugoa+-=rwxst" string. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int GetModeFromPermString(interp, modeStringPtr, modePtr) Tcl_Interp *interp; /* The interp we are using for errors. */ char *modeStringPtr; /* Permissions string */ mode_t *modePtr; /* pointer to the mode value */ { mode_t newMode; mode_t oldMode; /* Storage for the value of the old mode * (that is passed in), to allow for the * chmod style manipulation */ int i,n, who, op, what, op_found, who_found; /* * We start off checking for an "rwxrwxrwx" style permissions string */ if (strlen(modeStringPtr) != 9) { goto chmodStyleCheck; } newMode = 0; for (i = 0; i < 9; i++) { switch (*(modeStringPtr+i)) { case 'r': if ((i%3) != 0) { goto chmodStyleCheck; } newMode |= (1<<(8-i)); break; case 'w': if ((i%3) != 1) { goto chmodStyleCheck; } newMode |= (1<<(8-i)); break; case 'x': if ((i%3) != 2) { goto chmodStyleCheck; } newMode |= (1<<(8-i)); break; case 's': if (((i%3) != 2) || (i > 5)) { goto chmodStyleCheck; } newMode |= (1<<(8-i)); newMode |= (1<<(11-(i/3))); break; case 'S': if (((i%3) != 2) || (i > 5)) { goto chmodStyleCheck; } newMode |= (1<<(11-(i/3))); break; case 't': if (i != 8) { goto chmodStyleCheck; } newMode |= (1<<(8-i)); newMode |= (1<<9); break; case 'T': if (i != 8) { goto chmodStyleCheck; } newMode |= (1<<9); break; case '-': break; default: /* * Oops, not what we thought it was, so go on */ goto chmodStyleCheck; } } *modePtr = newMode; return TCL_OK; chmodStyleCheck: /* * We now check for an "ugoa+-=rwxst" style permissions string */ for (n = 0 ; *(modeStringPtr+n) != '\0' ; n = n + i) { oldMode = *modePtr; who = op = what = op_found = who_found = 0; for (i = 0 ; *(modeStringPtr+n+i) != '\0' ; i++ ) { if (!who_found) { /* who */ switch (*(modeStringPtr+n+i)) { case 'u' : who |= 0x9c0; continue; case 'g' : who |= 0x438; continue; case 'o' : who |= 0x207; continue; case 'a' : who |= 0xfff; continue; } } who_found = 1; if (who == 0) { who = 0xfff; } if (!op_found) { /* op */ switch (*(modeStringPtr+n+i)) { case '+' : op = 1; op_found = 1; continue; case '-' : op = 2; op_found = 1; continue; case '=' : op = 3; op_found = 1; continue; default : return TCL_ERROR; } } /* what */ switch (*(modeStringPtr+n+i)) { case 'r' : what |= 0x124; continue; case 'w' : what |= 0x92; continue; case 'x' : what |= 0x49; continue; case 's' : what |= 0xc00; continue; case 't' : what |= 0x200; continue; case ',' : break; default : return TCL_ERROR; } if (*(modeStringPtr+n+i) == ',') { i++; break; } } switch (op) { case 1 : *modePtr = oldMode | (who & what); continue; case 2 : *modePtr = oldMode & ~(who & what); continue; case 3 : *modePtr = (oldMode & ~who) | (who & what); continue; } } return TCL_OK; } /* *--------------------------------------------------------------------------- * * TclpObjNormalizePath -- * * This function scans through a path specification and replaces * it, in place, with a normalized version. A normalized version * is one in which all symlinks in the path are replaced with * their expanded form (except a symlink at the very end of the * path). * * Results: * The new 'nextCheckpoint' value, giving as far as we could * understand in the path. * * Side effects: * The pathPtr string, is modified. * *--------------------------------------------------------------------------- */ int TclpObjNormalizePath(interp, pathPtr, nextCheckpoint) Tcl_Interp *interp; Tcl_Obj *pathPtr; int nextCheckpoint; { char *currentPathEndPosition; int pathLen; char cur; char *path = Tcl_GetStringFromObj(pathPtr, &pathLen); #ifndef NO_REALPATH char normPath[MAXPATHLEN]; Tcl_DString ds; CONST char *nativePath; #endif /* * We add '1' here because if nextCheckpoint is zero we know * that '/' exists, and if it isn't zero, it must point at * a directory separator which we also know exists. */ currentPathEndPosition = path + nextCheckpoint; if (*currentPathEndPosition == '/') { currentPathEndPosition++; } #ifndef NO_REALPATH /* For speed, try to get the entire path in one go */ if (nextCheckpoint == 0) { char *lastDir = strrchr(currentPathEndPosition, '/'); if (lastDir != NULL) { nativePath = Tcl_UtfToExternalDString(NULL, path, lastDir - path, &ds); if (Realpath(nativePath, normPath) != NULL) { nextCheckpoint = lastDir - path; goto wholeStringOk; } } } /* Else do it the slow way */ #endif while (1) { cur = *currentPathEndPosition; if ((cur == '/') && (path != currentPathEndPosition)) { /* Reached directory separator */ Tcl_DString ds; CONST char *nativePath; int accessOk; nativePath = Tcl_UtfToExternalDString(NULL, path, currentPathEndPosition - path, &ds); accessOk = access(nativePath, F_OK); Tcl_DStringFree(&ds); if (accessOk != 0) { /* File doesn't exist */ break; } /* Update the acceptable point */ nextCheckpoint = currentPathEndPosition - path; } else if (cur == 0) { /* Reached end of string */ break; } currentPathEndPosition++; } /* * We should really now convert this to a canonical path. We do * that with 'realpath' if we have it available. Otherwise we could * step through every single path component, checking whether it is a * symlink, but that would be a lot of work, and most modern OSes * have 'realpath'. */ #ifndef NO_REALPATH /* * If we only had '/foo' or '/' then we never increment nextCheckpoint * and we don't need or want to go through 'Realpath'. Also, on some * platforms, passing an empty string to 'Realpath' will give us the * normalized pwd, which is not what we want at all! */ if (nextCheckpoint == 0) return 0; nativePath = Tcl_UtfToExternalDString(NULL, path, nextCheckpoint, &ds); if (Realpath(nativePath, normPath) != NULL) { int newNormLen; wholeStringOk: newNormLen = strlen(normPath); if ((newNormLen == Tcl_DStringLength(&ds)) && (strcmp(normPath, nativePath) == 0)) { /* String is unchanged */ Tcl_DStringFree(&ds); if (path[nextCheckpoint] != '\0') { nextCheckpoint++; } return nextCheckpoint; } /* * Free up the native path and put in its place the * converted, normalized path. */ Tcl_DStringFree(&ds); Tcl_ExternalToUtfDString(NULL, normPath, (int) newNormLen, &ds); if (path[nextCheckpoint] != '\0') { /* not at end, append remaining path */ int normLen = Tcl_DStringLength(&ds); Tcl_DStringAppend(&ds, path + nextCheckpoint, pathLen - nextCheckpoint); /* * We recognise up to and including the directory * separator. */ nextCheckpoint = normLen + 1; } else { /* We recognise the whole string */ nextCheckpoint = Tcl_DStringLength(&ds); } /* * Overwrite with the normalized path. */ Tcl_SetStringObj(pathPtr, Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)); } Tcl_DStringFree(&ds); #endif /* !NO_REALPATH */ return nextCheckpoint; } #if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) /* *---------------------------------------------------------------------- * * GetReadOnlyAttribute * * Gets the readonly attribute (user immutable flag) of a file. * * Results: * Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr * if there is no error. The object will have ref count 0. * * Side effects: * A new object is allocated. * *---------------------------------------------------------------------- */ static int GetReadOnlyAttribute(interp, objIndex, fileName, attributePtrPtr) Tcl_Interp *interp; /* The interp we are using for errors. */ int objIndex; /* The index of the attribute. */ Tcl_Obj *fileName; /* The name of the file (UTF-8). */ Tcl_Obj **attributePtrPtr; /* A pointer to return the object with. */ { Tcl_StatBuf statBuf; int result; result = TclpObjStat(fileName, &statBuf); if (result != 0) { Tcl_AppendResult(interp, "could not read \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } *attributePtrPtr = Tcl_NewBooleanObj((statBuf.st_flags & UF_IMMUTABLE) != 0); return TCL_OK; } /* *--------------------------------------------------------------------------- * * SetReadOnlyAttribute * * Sets the readonly attribute (user immutable flag) of a file. * * Results: * Standard TCL result. * * Side effects: * The readonly attribute of the file is changed. * *--------------------------------------------------------------------------- */ static int SetReadOnlyAttribute(interp, objIndex, fileName, attributePtr) Tcl_Interp *interp; /* The interp we are using for errors. */ int objIndex; /* The index of the attribute. */ Tcl_Obj *fileName; /* The name of the file (UTF-8). */ Tcl_Obj *attributePtr; /* The attribute to set. */ { Tcl_StatBuf statBuf; int result; int readonly; CONST char *native; if (Tcl_GetBooleanFromObj(interp, attributePtr, &readonly) != TCL_OK) { return TCL_ERROR; } result = TclpObjStat(fileName, &statBuf); if (result != 0) { Tcl_AppendResult(interp, "could not read \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } if (readonly) { statBuf.st_flags |= UF_IMMUTABLE; } else { statBuf.st_flags &= ~UF_IMMUTABLE; } native = Tcl_FSGetNativePath(fileName); result = chflags(native, statBuf.st_flags); /* INTL: Native. */ if (result != 0) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "could not set flags for file \"", Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } return TCL_OK; } #endif /* defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) */