diff -r 000000000000 -r bde4ae8d615e os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/unix/tclUnixFCmd.c
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/unix/tclUnixFCmd.c Fri Jun 15 03:10:57 2012 +0200
@@ -0,0 +1,1993 @@
+/*
+ * 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.
+ * Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved.
+ *
+ * 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.28.2.15 2007/04/29 02:19:51 das 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 <utime.h>
+#include <grp.h>
+#ifndef HAVE_ST_BLKSIZE
+#ifndef NO_FSTATFS
+#include <sys/statfs.h>
+#endif
+#endif
+#ifdef HAVE_FTS
+#include <fts.h>
+#endif
+
+#ifdef __SYMBIAN32__
+#include "convertPathSlashes.h"
+void TclPrint1(const char* aFmt, const char* aStr);
+#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));
+
+/*
+ * 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.
+ */
+
+enum {
+ UNIX_GROUP_ATTRIBUTE,
+ UNIX_OWNER_ATTRIBUTE,
+ UNIX_PERMISSIONS_ATTRIBUTE
+};
+
+CONST char *tclpFileAttrStrings[] = {
+ "-group",
+ "-owner",
+ "-permissions",
+ (char *) NULL
+};
+
+CONST TclFileAttrProcs tclpFileAttrProcs[] = {
+ {GetGroupAttribute, SetGroupAttribute},
+ {GetOwnerAttribute, SetOwnerAttribute},
+ {GetPermissionsAttribute, SetPermissionsAttribute}
+};
+
+/*
+ * 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 CopyFile _ANSI_ARGS_((CONST char *src,
+ CONST char *dst, CONST Tcl_StatBuf *statBufPtr));
+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, CONST Tcl_StatBuf *statBufPtr));
+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, 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 _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
+
+#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 threadsafe, c.f. bug 711232;
+ * if we might potentially be running on pre-10.3 OSX,
+ * check Darwin release at runtime before using realpath.
+ */
+extern long tclMacOSXDarwinRelease;
+#define haveRealpath (tclMacOSXDarwinRelease >= 7)
+#else
+#define haveRealpath 1
+#endif
+#endif /* NO_REALPATH */
+
+#ifdef HAVE_FTS
+#ifdef HAVE_STRUCT_STAT64
+/* 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.
+ */
+extern 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(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 && 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(srcPathPtr, destPathPtr)
+ 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(src, dst, statBufPtr)
+ 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 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;
+ }
+#ifdef HAVE_COPYFILE
+#ifdef WEAK_IMPORT_COPYFILE
+ if (copyfile != NULL)
+#endif
+ copyfile(src, dst, NULL, COPYFILE_XATTR|COPYFILE_NOFOLLOW_SRC);
+#endif
+ break;
+ }
+#endif
+ case S_IFBLK:
+ case S_IFCHR: {
+#ifdef __SYMBIAN32__
+ // not supported by PIPS
+ return TCL_ERROR;
+#else
+ if (mknod(dst, statBufPtr->st_mode, /* INTL: Native. */
+ statBufPtr->st_rdev) < 0) {
+ return TCL_ERROR;
+ }
+ return CopyFileAtts(src, dst, statBufPtr);
+#endif
+ }
+ case S_IFIFO: {
+ if (mkfifo(dst, statBufPtr->st_mode) < 0) { /* INTL: Native. */
+ return TCL_ERROR;
+ }
+ return CopyFileAtts(src, dst, statBufPtr);
+ }
+ default: {
+ return CopyFile(src, dst, statBufPtr);
+ }
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CopyFile -
+ *
+ * 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.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CopyFile(src, dst, statBufPtr)
+ 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 srcFd;
+ int dstFd;
+ unsigned blockSize; /* Optimal I/O blocksize for filesystem */
+ char *buffer; /* Data buffer for copy */
+ size_t nread;
+
+ if ((srcFd = TclOSopen(src, O_RDONLY, 0)) < 0) { /* INTL: Native. */
+ return TCL_ERROR;
+ }
+
+ dstFd = TclOSopen(dst, O_CREAT|O_TRUNC|O_WRONLY, /* 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
+
+ /* [SF Tcl Bug 1586470] Even if we HAVE_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 = 4096;
+ }
+ buffer = ckalloc(blockSize);
+ while (1) {
+ nread = read(srcFd, buffer, blockSize);
+ if ((nread == (size_t)-1) || (nread == 0)) {
+ break;
+ }
+ if (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 (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, 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(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);
+
+#ifdef __SYMBIAN32__
+ TclPrint1(" == DoRemoveDirectory() - \"%S\".\n", path);
+#endif
+
+ 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(traverseProc, sourcePtr, targetPtr, errorPtr, doRewind)
+ 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;
+ }
+
+ 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, 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 = 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 /* HAVE_FTS */
+
+ 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),
+ 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(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 HAVE_COPYFILE
+#ifdef WEAK_IMPORT_COPYFILE
+ if (copyfile != NULL)
+#endif
+ copyfile(src, dst, NULL, COPYFILE_XATTR|COPYFILE_ACL);
+#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 = TclpGetGrGid(statBuf.st_gid);
+
+ if (result == -1 || 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 = TclpGetPwUid(statBuf.st_uid);
+
+ if (result == -1 || 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 = TclpGetGrNam(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 = TclpGetPwNam(native); /* INTL: Native. */
+ Tcl_DStringFree(&ds);
+
+ if (pwPtr == NULL) {
+ endpwent();
+ 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. */
+
+ endpwent();
+ 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 && 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 */
+ 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 (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);
+ 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;
+}