diff options
Diffstat (limited to 'tcl8.6/unix/tclUnixFCmd.c')
| -rw-r--r-- | tcl8.6/unix/tclUnixFCmd.c | 2517 |
1 files changed, 0 insertions, 2517 deletions
diff --git a/tcl8.6/unix/tclUnixFCmd.c b/tcl8.6/unix/tclUnixFCmd.c deleted file mode 100644 index a1a409e..0000000 --- a/tcl8.6/unix/tclUnixFCmd.c +++ /dev/null @@ -1,2517 +0,0 @@ -/* - * 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. - * - * 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. 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 <utime.h> -#include <grp.h> -#ifndef HAVE_STRUCT_STAT_ST_BLKSIZE -#ifndef NO_FSTATFS -#include <sys/statfs.h> -#endif -#endif /* !HAVE_STRUCT_STAT_ST_BLKSIZE */ -#ifdef HAVE_FTS -#include <fts.h> -#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 */ - -/* - * Fallback temporary file location the temporary file generation code. Can be - * overridden at compile time for when it is known that temp files can't be - * written to /tmp (hello, iOS!). - */ - -#ifndef TCL_TEMPORARY_FILE_DIRECTORY -#define TCL_TEMPORARY_FILE_DIRECTORY "/tmp" -#endif - -/* - * Callbacks for file attributes code. - */ - -static int GetGroupAttribute(Tcl_Interp *interp, int objIndex, - Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); -static int GetOwnerAttribute(Tcl_Interp *interp, int objIndex, - Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); -static int GetPermissionsAttribute(Tcl_Interp *interp, - int objIndex, Tcl_Obj *fileName, - Tcl_Obj **attributePtrPtr); -static int SetGroupAttribute(Tcl_Interp *interp, int objIndex, - Tcl_Obj *fileName, Tcl_Obj *attributePtr); -static int SetOwnerAttribute(Tcl_Interp *interp, int objIndex, - Tcl_Obj *fileName, Tcl_Obj *attributePtr); -static int SetPermissionsAttribute(Tcl_Interp *interp, - int objIndex, Tcl_Obj *fileName, - Tcl_Obj *attributePtr); -static int GetModeFromPermString(Tcl_Interp *interp, - const char *modeStringPtr, mode_t *modePtr); -#if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) || defined(__CYGWIN__) -static int GetUnixFileAttributes(Tcl_Interp *interp, int objIndex, - Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); -static int SetUnixFileAttributes(Tcl_Interp *interp, int objIndex, - Tcl_Obj *fileName, Tcl_Obj *attributePtr); -#endif - -/* - * Prototype for the TraverseUnixTree callback function. - */ - -typedef int (TraversalProc)(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. - */ - -#ifdef DJGPP - -/* - * See contrib/djgpp/tclDjgppFCmd.c for definition. - */ - -extern TclFileAttrProcs tclpFileAttrProcs[]; -extern const char *const tclpFileAttrStrings[]; - -#else /* !DJGPP */ -enum { -#if defined(__CYGWIN__) - UNIX_ARCHIVE_ATTRIBUTE, -#endif - UNIX_GROUP_ATTRIBUTE, -#if defined(__CYGWIN__) - UNIX_HIDDEN_ATTRIBUTE, -#endif - UNIX_OWNER_ATTRIBUTE, UNIX_PERMISSIONS_ATTRIBUTE, -#if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) || defined(__CYGWIN__) - UNIX_READONLY_ATTRIBUTE, -#endif -#if defined(__CYGWIN__) - UNIX_SYSTEM_ATTRIBUTE, -#endif -#ifdef MAC_OSX_TCL - MACOSX_CREATOR_ATTRIBUTE, MACOSX_TYPE_ATTRIBUTE, MACOSX_HIDDEN_ATTRIBUTE, - MACOSX_RSRCLENGTH_ATTRIBUTE, -#endif - UNIX_INVALID_ATTRIBUTE /* lint - last enum value needs no trailing , */ -}; - -MODULE_SCOPE const char *const tclpFileAttrStrings[]; -const char *const tclpFileAttrStrings[] = { -#if defined(__CYGWIN__) - "-archive", -#endif - "-group", -#if defined(__CYGWIN__) - "-hidden", -#endif - "-owner", "-permissions", -#if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) || defined(__CYGWIN__) - "-readonly", -#endif -#if defined(__CYGWIN__) - "-system", -#endif -#ifdef MAC_OSX_TCL - "-creator", "-type", "-hidden", "-rsrclength", -#endif - NULL -}; - -MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[]; -const TclFileAttrProcs tclpFileAttrProcs[] = { -#if defined(__CYGWIN__) - {GetUnixFileAttributes, SetUnixFileAttributes}, -#endif - {GetGroupAttribute, SetGroupAttribute}, -#if defined(__CYGWIN__) - {GetUnixFileAttributes, SetUnixFileAttributes}, -#endif - {GetOwnerAttribute, SetOwnerAttribute}, - {GetPermissionsAttribute, SetPermissionsAttribute}, -#if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) || defined(__CYGWIN__) - {GetUnixFileAttributes, SetUnixFileAttributes}, -#endif -#if defined(__CYGWIN__) - {GetUnixFileAttributes, SetUnixFileAttributes}, -#endif -#ifdef MAC_OSX_TCL - {TclMacOSXGetFileAttribute, TclMacOSXSetFileAttribute}, - {TclMacOSXGetFileAttribute, TclMacOSXSetFileAttribute}, - {TclMacOSXGetFileAttribute, TclMacOSXSetFileAttribute}, - {TclMacOSXGetFileAttribute, TclMacOSXSetFileAttribute}, -#endif -}; -#endif /* DJGPP */ - -/* - * This is the maximum number of consecutive readdir/unlink calls that can be - * made (with no intervening rewinddir or closedir/opendir) before triggering - * a bug that makes readdir return NULL even though some directory entries - * have not been processed. The bug afflicts SunOS's readdir when applied to - * ufs file systems and Darwin 6.5's (and OSX v.10.3.8's) HFS+. JH found the - * Darwin readdir to reset at 147, so 130 is chosen to be conservative. We - * can't do a general rewind on failure as NFS can create special files that - * recreate themselves when you try and delete them. 8.4.8 added a solution - * that was affected by a single such NFS file, this solution should not be - * affected by less than THRESHOLD such files. [Bug 1034337] - */ - -#define MAX_READDIR_UNLINK_THRESHOLD 130 - -/* - * Declarations for local procedures defined in this file: - */ - -static int CopyFileAtts(const char *src, - const char *dst, const Tcl_StatBuf *statBufPtr); -static const char * DefaultTempDir(void); -static int DoCopyFile(const char *srcPtr, const char *dstPtr, - const Tcl_StatBuf *statBufPtr); -static int DoCreateDirectory(const char *pathPtr); -static int DoRemoveDirectory(Tcl_DString *pathPtr, - int recursive, Tcl_DString *errorPtr); -static int DoRenameFile(const char *src, const char *dst); -static int TraversalCopy(Tcl_DString *srcPtr, - Tcl_DString *dstPtr, - const Tcl_StatBuf *statBufPtr, int type, - Tcl_DString *errorPtr); -static int TraversalDelete(Tcl_DString *srcPtr, - Tcl_DString *dstPtr, - const Tcl_StatBuf *statBufPtr, int type, - Tcl_DString *errorPtr); -static int TraverseUnixTree(TraversalProc *traversalProc, - Tcl_DString *sourcePtr, Tcl_DString *destPtr, - Tcl_DString *errorPtr, int doRewind); - -#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(const char *path, char *resolved); - -char * -Realpath( - const char *path, - char *resolved) -{ - memset(resolved, 0, MAXPATHLEN); - return realpath(path, resolved); -} -#else -# define Realpath realpath -#endif /* PURIFY */ - -#ifndef NO_REALPATH -#if defined(__APPLE__) && defined(TCL_THREADS) && \ - defined(MAC_OS_X_VERSION_MIN_REQUIRED) && \ - MAC_OS_X_VERSION_MIN_REQUIRED < 1030 -/* - * Prior to Darwin 7, realpath is not thread-safe, c.f. Bug 711232; if we - * might potentially be running on pre-10.3 OSX, check Darwin release at - * runtime before using realpath. - */ - -MODULE_SCOPE long tclMacOSXDarwinRelease; -# define haveRealpath (tclMacOSXDarwinRelease >= 7) -#else -# define haveRealpath 1 -#endif -#endif /* NO_REALPATH */ - -#ifdef HAVE_FTS -#if defined(HAVE_STRUCT_STAT64) && !defined(__APPLE__) -/* fts doesn't do stat64 */ -# define noFtsStat 1 -#elif defined(__APPLE__) && defined(__LP64__) && \ - defined(MAC_OS_X_VERSION_MIN_REQUIRED) && \ - MAC_OS_X_VERSION_MIN_REQUIRED < 1050 -/* - * Prior to Darwin 9, 64bit fts_open() without FTS_NOSTAT may crash (due to a - * 64bit-unsafe ALIGN macro); if we could be running on pre-10.5 OSX, check - * Darwin release at runtime and do a separate stat() if necessary. - */ - -MODULE_SCOPE long tclMacOSXDarwinRelease; -# define noFtsStat (tclMacOSXDarwinRelease < 9) -#else -# define noFtsStat 0 -#endif -#endif /* HAVE_FTS */ - -/* - *--------------------------------------------------------------------------- - * - * 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( - Tcl_Obj *srcPathPtr, - Tcl_Obj *destPathPtr) -{ - return DoRenameFile(Tcl_FSGetNativePath(srcPathPtr), - Tcl_FSGetNativePath(destPathPtr)); -} - -static int -DoRenameFile( - 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 && haveRealpath) { - 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( - Tcl_Obj *srcPathPtr, - Tcl_Obj *destPathPtr) -{ - const char *src = Tcl_FSGetNativePath(srcPathPtr); - Tcl_StatBuf srcStatBuf; - - if (TclOSlstat(src, &srcStatBuf) != 0) { /* INTL: Native. */ - return TCL_ERROR; - } - - return DoCopyFile(src, Tcl_FSGetNativePath(destPathPtr), &srcStatBuf); -} - -static int -DoCopyFile( - const char *src, /* Pathname of file to be copied (native). */ - const char *dst, /* Pathname of file to copy to (native). */ - const Tcl_StatBuf *statBufPtr) - /* Used to determine filetype. */ -{ - Tcl_StatBuf dstStatBuf; - - if (S_ISDIR(statBufPtr->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) (statBufPtr->st_mode & S_IFMT)) { -#ifndef DJGPP - case S_IFLNK: { - char linkBuf[MAXPATHLEN+1]; - int length; - - length = readlink(src, linkBuf, MAXPATHLEN); - /* INTL: Native. */ - if (length == -1) { - return TCL_ERROR; - } - linkBuf[length] = '\0'; - if (symlink(linkBuf, dst) < 0) { /* INTL: Native. */ - return TCL_ERROR; - } -#ifdef MAC_OSX_TCL - TclMacOSXCopyFileAttributes(src, dst, statBufPtr); -#endif - break; - } -#endif /* !DJGPP */ - case S_IFBLK: - case S_IFCHR: - if (mknod(dst, statBufPtr->st_mode, /* INTL: Native. */ - statBufPtr->st_rdev) < 0) { - return TCL_ERROR; - } - return CopyFileAtts(src, dst, statBufPtr); - case S_IFIFO: - if (mkfifo(dst, statBufPtr->st_mode) < 0) { /* INTL: Native. */ - return TCL_ERROR; - } - return CopyFileAtts(src, dst, statBufPtr); - default: - return TclUnixCopyFile(src, dst, statBufPtr, 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( - 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, dstFd; - unsigned 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 /* DJGPP */ - -#define DEFAULT_COPY_BLOCK_SIZE 4096 - - 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; - } - - /* - * Try to work out the best size of buffer to use for copying. If we - * can't, it's no big deal as we can just use a (32-bit) page, since - * that's likely to be fairly efficient anyway. - */ - -#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE - blockSize = statBufPtr->st_blksize; -#elif !defined(NO_FSTATFS) - { - struct statfs fs; - - if (fstatfs(srcFd, &fs) == 0) { - blockSize = fs.f_bsize; - } else { - blockSize = DEFAULT_COPY_BLOCK_SIZE; - } - } -#else - blockSize = DEFAULT_COPY_BLOCK_SIZE; -#endif /* HAVE_STRUCT_STAT_ST_BLKSIZE */ - - /* - * [SF Tcl Bug 1586470] Even if we HAVE_STRUCT_STAT_ST_BLKSIZE, there are - * filesystems which report a bogus value for the blocksize. An example - * is the Andrew Filesystem (afs), reporting a blocksize of 0. When - * detecting such a situation we now simply fall back to a hardwired - * default size. - */ - - if (blockSize <= 0) { - blockSize = DEFAULT_COPY_BLOCK_SIZE; - } - buffer = ckalloc(blockSize); - while (1) { - nread = (size_t) read(srcFd, buffer, blockSize); - if ((nread == (size_t) -1) || (nread == 0)) { - break; - } - if ((size_t) write(dstFd, buffer, nread) != nread) { - nread = (size_t) -1; - break; - } - } - - ckfree(buffer); - close(srcFd); - if ((close(dstFd) != 0) || (nread == (size_t) -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( - Tcl_Obj *pathPtr) -{ - return TclpDeleteFile(Tcl_FSGetNativePath(pathPtr)); -} - -int -TclpDeleteFile( - const void *path) /* Pathname of file to be removed (native). */ -{ - if (unlink((const char *)path) != 0) { - 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( - Tcl_Obj *pathPtr) -{ - return DoCreateDirectory(Tcl_FSGetNativePath(pathPtr)); -} - -static int -DoCreateDirectory( - 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( - 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 ? TclGetString(transPtr) : NULL), - -1, &srcString); - if (transPtr != NULL) { - Tcl_DecrRefCount(transPtr); - } - transPtr = Tcl_FSGetTranslatedPath(NULL,destPathPtr); - Tcl_UtfToExternalDString(NULL, - (transPtr != NULL ? TclGetString(transPtr) : NULL), - -1, &dstString); - if (transPtr != NULL) { - Tcl_DecrRefCount(transPtr); - } - - ret = TraverseUnixTree(TraversalCopy, &srcString, &dstString, &ds, 0); - - 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( - 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 ? TclGetString(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( - 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, 1); - } - - 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( - 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. */ - int doRewind) /* Flag indicating that to ensure complete - * traversal of source hierarchy, the readdir - * loop should be rewound whenever - * traverseProc has returned TCL_OK; this is - * required when traverseProc modifies the - * source hierarchy, e.g. by deleting - * files. */ -{ - Tcl_StatBuf statBuf; - const char *source, *errfile; - int result, sourceLen; - int targetLen; -#ifndef HAVE_FTS - int numProcessed = 0; - Tcl_DirEntry *dirEntPtr; - DIR *dirPtr; -#else - const char *paths[2] = {NULL, NULL}; - FTS *fts = NULL; - FTSENT *ent; -#endif - - 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); - } -#ifndef HAVE_FTS - 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; - } - - TclDStringAppendLiteral(sourcePtr, "/"); - sourceLen = Tcl_DStringLength(sourcePtr); - - if (targetPtr != NULL) { - TclDStringAppendLiteral(targetPtr, "/"); - 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, doRewind); - if (result != TCL_OK) { - break; - } else { - numProcessed++; - } - - /* - * Remove name after slash. - */ - - Tcl_DStringSetLength(sourcePtr, sourceLen); - if (targetPtr != NULL) { - Tcl_DStringSetLength(targetPtr, targetLen); - } - if (doRewind && (numProcessed > MAX_READDIR_UNLINK_THRESHOLD)) { - /* - * Call rewinddir if we've called unlink or rmdir so many times - * (since the opendir or the previous rewinddir), to avoid a - * NULL-return that may a symptom of a buggy readdir. - */ - - rewinddir(dirPtr); - numProcessed = 0; - } - } - 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); - } -#else /* HAVE_FTS */ - paths[0] = source; - fts = fts_open((char **) paths, FTS_PHYSICAL | FTS_NOCHDIR | - (noFtsStat || doRewind ? FTS_NOSTAT : 0), NULL); - if (fts == NULL) { - errfile = source; - goto end; - } - - sourceLen = Tcl_DStringLength(sourcePtr); - if (targetPtr != NULL) { - targetLen = Tcl_DStringLength(targetPtr); - } - - while ((ent = fts_read(fts)) != NULL) { - unsigned short info = ent->fts_info; - char *path = ent->fts_path + sourceLen; - unsigned short pathlen = ent->fts_pathlen - sourceLen; - int type; - Tcl_StatBuf *statBufPtr = NULL; - - if (info == FTS_DNR || info == FTS_ERR || info == FTS_NS) { - errfile = ent->fts_path; - break; - } - Tcl_DStringAppend(sourcePtr, path, pathlen); - if (targetPtr != NULL) { - Tcl_DStringAppend(targetPtr, path, pathlen); - } - switch (info) { - case FTS_D: - type = DOTREE_PRED; - break; - case FTS_DP: - type = DOTREE_POSTD; - break; - default: - type = DOTREE_F; - break; - } - if (!doRewind) { /* no need to stat for delete */ - if (noFtsStat) { - statBufPtr = &statBuf; - if (TclOSlstat(ent->fts_path, statBufPtr) != 0) { - errfile = ent->fts_path; - break; - } - } else { - statBufPtr = (Tcl_StatBuf *) ent->fts_statp; - } - } - result = traverseProc(sourcePtr, targetPtr, statBufPtr, type, - errorPtr); - if (result != TCL_OK) { - break; - } - Tcl_DStringSetLength(sourcePtr, sourceLen); - if (targetPtr != NULL) { - Tcl_DStringSetLength(targetPtr, targetLen); - } - } -#endif /* !HAVE_FTS */ - - end: - if (errfile != NULL) { - if (errorPtr != NULL) { - Tcl_ExternalToUtfDString(NULL, errfile, -1, errorPtr); - } - result = TCL_ERROR; - } -#ifdef HAVE_FTS - if (fts != NULL) { - fts_close(fts); - } -#endif - - 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( - 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), - statBufPtr) == 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( - 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( - 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( - 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) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "could not read \"%s\": %s", - TclGetString(fileName), Tcl_PosixError(interp))); - } - return TCL_ERROR; - } - - groupPtr = TclpGetGrGid(statBuf.st_gid); - - 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); - } - 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( - 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) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "could not read \"%s\": %s", - TclGetString(fileName), Tcl_PosixError(interp))); - } - return TCL_ERROR; - } - - pwPtr = TclpGetPwUid(statBuf.st_uid); - - if (pwPtr == NULL) { - *attributePtrPtr = Tcl_NewIntObj((int) statBuf.st_uid); - } else { - Tcl_DString ds; - - (void) Tcl_ExternalToUtfDString(NULL, pwPtr->pw_name, -1, &ds); - *attributePtrPtr = TclDStringToObj(&ds); - } - 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( - 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) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "could not read \"%s\": %s", - TclGetString(fileName), Tcl_PosixError(interp))); - } - return TCL_ERROR; - } - - *attributePtrPtr = Tcl_ObjPrintf( - "%0#5lo", (long) (statBuf.st_mode & 0x00007FFF)); - 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( - 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 = NULL; - const char *string; - int length; - - string = Tcl_GetStringFromObj(attributePtr, &length); - - native = Tcl_UtfToExternalDString(NULL, string, length, &ds); - groupPtr = TclpGetGrNam(native); /* INTL: Native. */ - Tcl_DStringFree(&ds); - - if (groupPtr == NULL) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "could not set group for file \"%s\":" - " group \"%s\" does not exist", - TclGetString(fileName), string)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SETGRP", - "NO_GROUP", NULL); - } - return TCL_ERROR; - } - gid = groupPtr->gr_gid; - } - - native = Tcl_FSGetNativePath(fileName); - result = chown(native, (uid_t) -1, (gid_t) gid); /* INTL: Native. */ - - if (result != 0) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "could not set group for file \"%s\": %s", - TclGetString(fileName), Tcl_PosixError(interp))); - } - 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( - 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 = NULL; - const char *string; - int length; - - string = Tcl_GetStringFromObj(attributePtr, &length); - - native = Tcl_UtfToExternalDString(NULL, string, length, &ds); - pwPtr = TclpGetPwNam(native); /* INTL: Native. */ - Tcl_DStringFree(&ds); - - if (pwPtr == NULL) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "could not set owner for file \"%s\":" - " user \"%s\" does not exist", - TclGetString(fileName), string)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SETOWN", - "NO_USER", 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) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "could not set owner for file \"%s\": %s", - TclGetString(fileName), Tcl_PosixError(interp))); - } - 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( - 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 = TCL_ERROR; - const char *native; - const char *modeStringPtr = TclGetString(attributePtr); - int scanned = TclParseAllWhiteSpace(modeStringPtr, -1); - - /* - * First supply support for octal number format - */ - - if ((modeStringPtr[scanned] == '0') - && (modeStringPtr[scanned+1] >= '0') - && (modeStringPtr[scanned+1] <= '7')) { - /* Leading zero - attempt octal interpretation */ - Tcl_Obj *modeObj; - - TclNewLiteralStringObj(modeObj, "0o"); - Tcl_AppendToObj(modeObj, modeStringPtr+scanned+1, -1); - result = Tcl_GetLongFromObj(NULL, modeObj, &mode); - Tcl_DecrRefCount(modeObj); - } - if (result == TCL_OK - || Tcl_GetLongFromObj(NULL, attributePtr, &mode) == TCL_OK) { - newMode = (mode_t) (mode & 0x00007FFF); - } else { - Tcl_StatBuf buf; - - /* - * 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) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "could not read \"%s\": %s", - TclGetString(fileName), Tcl_PosixError(interp))); - } - return TCL_ERROR; - } - newMode = (mode_t) (buf.st_mode & 0x00007FFF); - - if (GetModeFromPermString(NULL, modeStringPtr, &newMode) != TCL_OK) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "unknown permission string format \"%s\"", - modeStringPtr)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "PERMISSION", NULL); - } - return TCL_ERROR; - } - } - - native = Tcl_FSGetNativePath(fileName); - result = chmod(native, newMode); /* INTL: Native. */ - if (result != 0) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "could not set permissions for file \"%s\": %s", - TclGetString(fileName), Tcl_PosixError(interp))); - } - return TCL_ERROR; - } - return TCL_OK; -} - -#ifndef DJGPP -/* - *--------------------------------------------------------------------------- - * - * 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; - TclNewLiteralStringObj(resultPtr, "/"); - - Tcl_IncrRefCount(resultPtr); - return resultPtr; -} -#endif - -/* - *---------------------------------------------------------------------- - * - * 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( - Tcl_Interp *interp, /* The interp we are using for errors. */ - const 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( - Tcl_Interp *interp, - Tcl_Obj *pathPtr, - int nextCheckpoint) -{ - const char *currentPathEndPosition; - int pathLen; - char cur; - const char *path = Tcl_GetStringFromObj(pathPtr, &pathLen); - Tcl_DString ds; - const char *nativePath; -#ifndef NO_REALPATH - char normPath[MAXPATHLEN]; -#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 && haveRealpath) { - char *lastDir = strrchr(currentPathEndPosition, '/'); - - if (lastDir != NULL) { - nativePath = Tcl_UtfToExternalDString(NULL, path, - lastDir-path, &ds); - if (Realpath(nativePath, normPath) != NULL) { - if (*nativePath != '/' && *normPath == '/') { - /* - * realpath has transformed a relative path into an - * absolute path, we do not know how to handle this. - */ - } else { - nextCheckpoint = lastDir - path; - goto wholeStringOk; - } - } - Tcl_DStringFree(&ds); - } - } - - /* - * Else do it the slow way. - */ -#endif - - while (1) { - cur = *currentPathEndPosition; - if ((cur == '/') && (path != currentPathEndPosition)) { - /* - * Reached directory separator. - */ - - 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 (haveRealpath) { - /* - * 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); - - /* - * Enable this to have the native FS claim normalization of - * the whole path for existing files. That would permit the - * caller to declare normalization complete without calls to - * additional filesystems. Saving lots of calls is probably - * worth the extra access() time here. When no other FS's are - * registered though, things are less clear. - * - if (0 == access(normPath, F_OK)) { - return pathLen; - } - */ - - 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; -} - -/* - *---------------------------------------------------------------------- - * - * TclpOpenTemporaryFile, TclUnixOpenTemporaryFile -- - * - * Creates a temporary file, possibly based on the supplied bits and - * pieces of template supplied in the first three arguments. If the - * fourth argument is non-NULL, it contains a Tcl_Obj to store the name - * of the temporary file in (and it is caller's responsibility to clean - * up). If the fourth argument is NULL, try to arrange for the temporary - * file to go away once it is no longer needed. - * - * Results: - * A read-write Tcl Channel open on the file for TclpOpenTemporaryFile, - * or a file descriptor (or -1 on failure) for TclUnixOpenTemporaryFile. - * - * Side effects: - * Accesses the filesystem. Will set the contents of the Tcl_Obj fourth - * argument (if that is non-NULL). - * - *---------------------------------------------------------------------- - */ - -Tcl_Channel -TclpOpenTemporaryFile( - Tcl_Obj *dirObj, - Tcl_Obj *basenameObj, - Tcl_Obj *extensionObj, - Tcl_Obj *resultingNameObj) -{ - int fd = TclUnixOpenTemporaryFile(dirObj, basenameObj, extensionObj, - resultingNameObj); - - if (fd == -1) { - return NULL; - } - return Tcl_MakeFileChannel(INT2PTR(fd), TCL_READABLE|TCL_WRITABLE); -} - -int -TclUnixOpenTemporaryFile( - Tcl_Obj *dirObj, - Tcl_Obj *basenameObj, - Tcl_Obj *extensionObj, - Tcl_Obj *resultingNameObj) -{ - Tcl_DString template, tmp; - const char *string; - int len, fd; - - /* - * We should also check against making more then TMP_MAX of these. - */ - - if (dirObj) { - string = Tcl_GetStringFromObj(dirObj, &len); - Tcl_UtfToExternalDString(NULL, string, len, &template); - } else { - Tcl_DStringInit(&template); - Tcl_DStringAppend(&template, DefaultTempDir(), -1); /* INTL: native */ - } - - TclDStringAppendLiteral(&template, "/"); - - if (basenameObj) { - string = Tcl_GetStringFromObj(basenameObj, &len); - Tcl_UtfToExternalDString(NULL, string, len, &tmp); - TclDStringAppendDString(&template, &tmp); - Tcl_DStringFree(&tmp); - } else { - TclDStringAppendLiteral(&template, "tcl"); - } - - TclDStringAppendLiteral(&template, "_XXXXXX"); - -#ifdef HAVE_MKSTEMPS - if (extensionObj) { - string = Tcl_GetStringFromObj(extensionObj, &len); - Tcl_UtfToExternalDString(NULL, string, len, &tmp); - TclDStringAppendDString(&template, &tmp); - fd = mkstemps(Tcl_DStringValue(&template), Tcl_DStringLength(&tmp)); - Tcl_DStringFree(&tmp); - } else -#endif - { - fd = mkstemp(Tcl_DStringValue(&template)); - } - - if (fd == -1) { - Tcl_DStringFree(&template); - return -1; - } - - if (resultingNameObj) { - Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&template), - Tcl_DStringLength(&template), &tmp); - Tcl_SetStringObj(resultingNameObj, Tcl_DStringValue(&tmp), - Tcl_DStringLength(&tmp)); - Tcl_DStringFree(&tmp); - } else { - /* - * Try to delete the file immediately since we're not reporting the - * name to anyone. Note that we're *not* handling any errors from - * this! - */ - - unlink(Tcl_DStringValue(&template)); - errno = 0; - } - Tcl_DStringFree(&template); - - return fd; -} - -/* - * Helper that does *part* of what tempnam() does. - */ - -static const char * -DefaultTempDir(void) -{ - const char *dir; - struct stat buf; - - dir = getenv("TMPDIR"); - if (dir && dir[0] && stat(dir, &buf) == 0 && S_ISDIR(buf.st_mode) - && access(dir, W_OK) == 0) { - return dir; - } - -#ifdef P_tmpdir - dir = P_tmpdir; - if (stat(dir, &buf)==0 && S_ISDIR(buf.st_mode) && access(dir, W_OK)==0) { - return dir; - } -#endif - - /* - * Assume that the default location ("/tmp" if not overridden) is always - * an existing writable directory; we've no recovery mechanism if it - * isn't. - */ - - return TCL_TEMPORARY_FILE_DIRECTORY; -} - -#if defined(__CYGWIN__) - -static void -StatError( - Tcl_Interp *interp, /* The interp that has the error */ - Tcl_Obj *fileName) /* The name of the file which caused the - * error. */ -{ - TclWinConvertError(GetLastError()); - Tcl_SetObjResult(interp, Tcl_ObjPrintf("could not read \"%s\": %s", - TclGetString(fileName), Tcl_PosixError(interp))); -} - -static WCHAR * -winPathFromObj( - Tcl_Obj *fileName) -{ - int size; - const char *native = Tcl_FSGetNativePath(fileName); - WCHAR *winPath; - - size = cygwin_conv_path(1, native, NULL, 0); - winPath = ckalloc(size); - cygwin_conv_path(1, native, winPath, size); - - return winPath; -} - -static const int attributeArray[] = { - 0x20, 0, 2, 0, 0, 1, 4}; - -/* - *---------------------------------------------------------------------- - * - * GetUnixFileAttributes - * - * Gets the readonly 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 -GetUnixFileAttributes( - 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. */ -{ - int fileAttributes; - WCHAR *winPath = winPathFromObj(fileName); - - fileAttributes = GetFileAttributesW(winPath); - ckfree(winPath); - - if (fileAttributes == -1) { - StatError(interp, fileName); - return TCL_ERROR; - } - - *attributePtrPtr = Tcl_NewIntObj((fileAttributes&attributeArray[objIndex])!=0); - - return TCL_OK; -} - -/* - *--------------------------------------------------------------------------- - * - * SetUnixFileAttributes - * - * Sets the readonly attribute of a file. - * - * Results: - * Standard TCL result. - * - * Side effects: - * The readonly attribute of the file is changed. - * - *--------------------------------------------------------------------------- - */ - -static int -SetUnixFileAttributes( - 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. */ -{ - int yesNo, fileAttributes, old; - WCHAR *winPath; - - if (Tcl_GetBooleanFromObj(interp, attributePtr, &yesNo) != TCL_OK) { - return TCL_ERROR; - } - - winPath = winPathFromObj(fileName); - - fileAttributes = old = GetFileAttributesW(winPath); - - if (fileAttributes == -1) { - ckfree(winPath); - StatError(interp, fileName); - return TCL_ERROR; - } - - if (yesNo) { - fileAttributes |= attributeArray[objIndex]; - } else { - fileAttributes &= ~attributeArray[objIndex]; - } - - if ((fileAttributes != old) - && !SetFileAttributesW(winPath, fileAttributes)) { - ckfree(winPath); - StatError(interp, fileName); - return TCL_ERROR; - } - - ckfree(winPath); - return TCL_OK; -} -#elif defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) -/* - *---------------------------------------------------------------------- - * - * GetUnixFileAttributes - * - * 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 -GetUnixFileAttributes( - 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) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "could not read \"%s\": %s", - TclGetString(fileName), Tcl_PosixError(interp))); - } - return TCL_ERROR; - } - - *attributePtrPtr = Tcl_NewBooleanObj(statBuf.st_flags&UF_IMMUTABLE); - - return TCL_OK; -} - -/* - *--------------------------------------------------------------------------- - * - * SetUnixFileAttributes - * - * 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 -SetUnixFileAttributes( - 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, readonly; - const char *native; - - if (Tcl_GetBooleanFromObj(interp, attributePtr, &readonly) != TCL_OK) { - return TCL_ERROR; - } - - result = TclpObjStat(fileName, &statBuf); - - if (result != 0) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "could not read \"%s\": %s", - TclGetString(fileName), Tcl_PosixError(interp))); - } - 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) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "could not set flags for file \"%s\": %s", - TclGetString(fileName), Tcl_PosixError(interp))); - } - return TCL_ERROR; - } - return TCL_OK; -} -#endif /* defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) */ - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ |