/*
 * tclUnixFCmd.c
 *
 *      This file implements the unix specific portion of file manipulation 
 *      subcommands of the "file" command.  All filename arguments should
 *  already be translated to native format.
 *
 * Copyright (c) 1996-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) Id
 *
 * 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

/*
 * 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


/*
 *---------------------------------------------------------------------------
 *
 * TclpObjRenameFile, DoRenameFile --
 *
 *      Changes the name of an existing file or directory, from src to dst.
 *  If src and dst refer to the same file or directory, does nothing
 *  and returns success.  Otherwise if dst already exists, it will be
 *  deleted and replaced by src subject to the following conditions:
 *      If src is a directory, dst may be an empty directory.
 *      If src is a file, dst may be a file.
 *  In any other situation where dst already exists, the rename will
 *  fail.  
 *
 * Results:
 *  If the directory was successfully created, returns TCL_OK.
 *  Otherwise the return value is TCL_ERROR and errno is set to
 *  indicate the error.  Some possible values for errno are:
 *
 *  EACCES:     src or dst parent directory can't be read and/or written.
 *  EEXIST:      dst is a non-empty directory.
 *  EINVAL:      src is a root directory or dst is a subdirectory of src.
 *  EISDIR:      dst is a directory, but src is not.
 *  ENOENT:      src doesn't exist, or src or dst is "".
 *  ENOTDIR:    src is a directory, but dst is not.  
 *  EXDEV:      src and dst are on different filesystems.
 *  
 * Side effects:
 *  The implementation of rename may allow cross-filesystem renames,
 *  but the caller should be prepared to emulate it with copy and
 *  delete if errno is EXDEV.
 *
 *---------------------------------------------------------------------------
 */

int 
TclpObjRenameFile(srcPathPtr, destPathPtr)
    Tcl_Obj *srcPathPtr;
    Tcl_Obj *destPathPtr;
{
    return DoRenameFile(Tcl_FSGetNativePath(srcPathPtr), 
      Tcl_FSGetNativePath(destPathPtr));
}

static int
DoRenameFile(src, dst)
    CONST char *src;    /* Pathname of file or dir to be renamed
         * (native). */
    CONST char *dst;    /* New pathname of file or directory
         * (native). */
{
    if (rename(src, dst) == 0) {      /* INTL: Native. */
  return TCL_OK;
    }
    if (errno == ENOTEMPTY) {
  errno = EEXIST;
    }

    /*
     * IRIX returns EIO when you attept to move a directory into
     * itself.  We just map EIO to EINVAL get the right message on SGI.
     * Most platforms don't return EIO except in really strange cases.
     */
    
    if (errno == EIO) {
  errno = EINVAL;
    }
    
#ifndef NO_REALPATH
    /*
     * SunOS 4.1.4 reports overwriting a non-empty directory with a
     * directory as EINVAL instead of EEXIST (first rule out the correct
     * EINVAL result code for moving a directory into itself).  Must be
     * conditionally compiled because realpath() not defined on all systems.
     */

    if (errno == EINVAL) {
  char srcPath[MAXPATHLEN], dstPath[MAXPATHLEN];
  DIR *dirPtr;
  Tcl_DirEntry *dirEntPtr;

  if ((Realpath((char *) src, srcPath) != NULL)  /* INTL: Native. */
    && (Realpath((char *) dst, dstPath) != NULL) /* INTL: Native. */
    && (strncmp(srcPath, dstPath, strlen(srcPath)) != 0)) {
      dirPtr = opendir(dst);      /* INTL: Native. */
      if (dirPtr != NULL) {
    while (1) {
        dirEntPtr = TclOSreaddir(dirPtr); /* INTL: Native. */
        if (dirEntPtr == NULL) {
      break;
        }
        if ((strcmp(dirEntPtr->d_name, ".") != 0) &&
          (strcmp(dirEntPtr->d_name, "..") != 0)) {
      errno = EEXIST;
      closedir(dirPtr);
      return TCL_ERROR;
        }
    }
    closedir(dirPtr);
      }
  }
  errno = EINVAL;
    }
#endif  /* !NO_REALPATH */

    if (strcmp(src, "/") == 0) {
  /*
   * Alpha reports renaming / as EBUSY and Linux reports it as EACCES,
   * instead of EINVAL.
   */
   
  errno = EINVAL;
    }

    /*
     * DEC Alpha OSF1 V3.0 returns EACCES when attempting to move a
     * file across filesystems and the parent directory of that file is
     * not writable.  Most other systems return EXDEV.  Does nothing to
     * correct this behavior.
     */

    return TCL_ERROR;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpObjCopyFile, DoCopyFile --
 *
 *      Copy a single file (not a directory).  If dst already exists and
 *  is not a directory, it is removed.
 *
 * Results:
 *  If the file was successfully copied, returns TCL_OK.  Otherwise
 *  the return value is TCL_ERROR and errno is set to indicate the
 *  error.  Some possible values for errno are:
 *
 *  EACCES:     src or dst parent directory can't be read and/or written.
 *  EISDIR:      src or dst is a directory.
 *  ENOENT:      src doesn't exist.  src or dst is "".
 *
 * Side effects:
 *      This procedure will also copy symbolic links, block, and
 *      character devices, and fifos.  For symbolic links, the links 
 *      themselves will be copied and not what they point to.  For the
 *  other special file types, the directory entry will be copied and
 *  not the contents of the device that it refers to.
 *
 *---------------------------------------------------------------------------
 */

int 
TclpObjCopyFile(srcPathPtr, destPathPtr)
    Tcl_Obj *srcPathPtr;
    Tcl_Obj *destPathPtr;
{
    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
      copyfile(src, dst, NULL, COPYFILE_XATTR|COPYFILE_NOFOLLOW_SRC);
#endif
      break;
  }
#endif
        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 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

    buffer = ckalloc(blockSize);
    while (1) {
  nread = read(srcFd, buffer, blockSize);
  if ((nread == -1) || (nread == 0)) {
      break;
  }
  if (write(dstFd, buffer, nread) != nread) {
      nread = (size_t) -1;
      break;
  }
    }

    ckfree(buffer);
    close(srcFd);
    if ((close(dstFd) != 0) || (nread == -1)) {
  unlink(dst);          /* INTL: Native. */
  return TCL_ERROR;
    }
    if (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);
    
    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|
#ifdef HAVE_STRUCT_STAT64
      FTS_NOSTAT,        /* fts doesn't do stat64 */
#else
      (doRewind ? FTS_NOSTAT : 0),  /* no need to stat for delete */
#endif
      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 */
#ifdef HAVE_STRUCT_STAT64
      statBufPtr = &statBuf;
      if (TclOSlstat(ent->fts_path, statBufPtr) != 0) {
    errfile = ent->fts_path;
    break;
      }
#else
      statBufPtr = ent->fts_statp;
#endif
  }
  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
    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 = getgrgid(statBuf.st_gid);    /* INTL: Native. */
    if (groupPtr == NULL) {
  *attributePtrPtr = Tcl_NewIntObj((int) statBuf.st_gid);
    } else {
  Tcl_DString ds;
  CONST char *utf;

  utf = Tcl_ExternalToUtfDString(NULL, groupPtr->gr_name, -1, &ds); 
  *attributePtrPtr = Tcl_NewStringObj(utf, -1);
  Tcl_DStringFree(&ds);
    }
    endgrent();
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * GetOwnerAttribute
 *
 *      Gets the owner attribute of a file.
 *
 * Results:
 *      Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr
 *  if there is no error.
 *
 * Side effects:
 *      A new object is allocated.
 *      
 *----------------------------------------------------------------------
 */

static int
GetOwnerAttribute(interp, objIndex, fileName, attributePtrPtr)
    Tcl_Interp *interp;    /* The interp we are using for errors. */
    int objIndex;    /* The index of the attribute. */
    Tcl_Obj *fileName;    /* The name of the file (UTF-8). */
    Tcl_Obj **attributePtrPtr;  /* A pointer to return the object with. */
{
    Tcl_StatBuf statBuf;
    struct passwd *pwPtr;
    int result;

    result = TclpObjStat(fileName, &statBuf);
    
    if (result != 0) {
  Tcl_AppendResult(interp, "could not read \"", 
    Tcl_GetString(fileName), "\": ",
    Tcl_PosixError(interp), (char *) NULL);
  return TCL_ERROR;
    }

    pwPtr = getpwuid(statBuf.st_uid);      /* INTL: Native. */
    if (pwPtr == NULL) {
  *attributePtrPtr = Tcl_NewIntObj((int) statBuf.st_uid);
    } else {
  Tcl_DString ds;
  CONST char *utf;

  utf = Tcl_ExternalToUtfDString(NULL, pwPtr->pw_name, -1, &ds); 
  *attributePtrPtr = Tcl_NewStringObj(utf, Tcl_DStringLength(&ds));
  Tcl_DStringFree(&ds);
    }
    endpwent();
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * GetPermissionsAttribute
 *
 *      Gets the group attribute of a file.
 *
 * Results:
 *      Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr
 *  if there is no error. The object will have ref count 0.
 *
 * Side effects:
 *      A new object is allocated.
 *      
 *----------------------------------------------------------------------
 */

static int
GetPermissionsAttribute(interp, objIndex, fileName, attributePtrPtr)
    Tcl_Interp *interp;        /* The interp we are using for errors. */
    int objIndex;        /* The index of the attribute. */
    Tcl_Obj *fileName;        /* The name of the file (UTF-8). */
    Tcl_Obj **attributePtrPtr;      /* A pointer to return the object with. */
{
    Tcl_StatBuf statBuf;
    char returnString[7];
    int result;

    result = TclpObjStat(fileName, &statBuf);
    
    if (result != 0) {
  Tcl_AppendResult(interp, "could not read \"", 
    Tcl_GetString(fileName), "\": ",
    Tcl_PosixError(interp), (char *) NULL);
  return TCL_ERROR;
    }

    sprintf(returnString, "%0#5lo", (long) (statBuf.st_mode & 0x00007FFF));

    *attributePtrPtr = Tcl_NewStringObj(returnString, -1);
    
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * SetGroupAttribute --
 *
 *      Sets the group of the file to the specified group.
 *
 * Results:
 *      Standard TCL result.
 *
 * Side effects:
 *      As above.
 *      
 *---------------------------------------------------------------------------
 */

static int
SetGroupAttribute(interp, objIndex, fileName, attributePtr)
    Tcl_Interp *interp;        /* The interp for error reporting. */
    int objIndex;        /* The index of the attribute. */
    Tcl_Obj *fileName;              /* The name of the file (UTF-8). */
    Tcl_Obj *attributePtr;      /* New group for file. */
{
    long gid;
    int result;
    CONST char *native;

    if (Tcl_GetLongFromObj(NULL, attributePtr, &gid) != TCL_OK) {
  Tcl_DString ds;
  struct group *groupPtr;
  CONST char *string;
  int length;

  string = Tcl_GetStringFromObj(attributePtr, &length);

  native = Tcl_UtfToExternalDString(NULL, string, length, &ds);
  groupPtr = getgrnam(native);      /* INTL: Native. */
  Tcl_DStringFree(&ds);

  if (groupPtr == NULL) {
      endgrent();
      Tcl_AppendResult(interp, "could not set group for file \"",
        Tcl_GetString(fileName), "\": group \"", 
        string, "\" does not exist",
        (char *) NULL);
      return TCL_ERROR;
  }
  gid = groupPtr->gr_gid;
    }

    native = Tcl_FSGetNativePath(fileName);
    result = chown(native, (uid_t) -1, (gid_t) gid);  /* INTL: Native. */

    endgrent();
    if (result != 0) {
  Tcl_AppendResult(interp, "could not set group for file \"",
      Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp), 
      (char *) NULL);
  return TCL_ERROR;
    }    
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * SetOwnerAttribute --
 *
 *      Sets the owner of the file to the specified owner.
 *
 * Results:
 *      Standard TCL result.
 *
 * Side effects:
 *      As above.
 *      
 *---------------------------------------------------------------------------
 */

static int
SetOwnerAttribute(interp, objIndex, fileName, attributePtr)
    Tcl_Interp *interp;        /* The interp for error reporting. */
    int objIndex;        /* The index of the attribute. */
    Tcl_Obj *fileName;         /* The name of the file (UTF-8). */
    Tcl_Obj *attributePtr;      /* New owner for file. */
{
    long uid;
    int result;
    CONST char *native;

    if (Tcl_GetLongFromObj(NULL, attributePtr, &uid) != TCL_OK) {
  Tcl_DString ds;
  struct passwd *pwPtr;
  CONST char *string;
  int length;

  string = Tcl_GetStringFromObj(attributePtr, &length);

  native = Tcl_UtfToExternalDString(NULL, string, length, &ds);
  pwPtr = getpwnam(native);      /* INTL: Native. */
  Tcl_DStringFree(&ds);

  if (pwPtr == NULL) {
      Tcl_AppendResult(interp, "could not set owner for file \"",
           Tcl_GetString(fileName), "\": user \"", 
           string, "\" does not exist",
        (char *) NULL);
      return TCL_ERROR;
  }
  uid = pwPtr->pw_uid;
    }

    native = Tcl_FSGetNativePath(fileName);
    result = chown(native, (uid_t) uid, (gid_t) -1);   /* INTL: Native. */

    if (result != 0) {
  Tcl_AppendResult(interp, "could not set owner for file \"", 
       Tcl_GetString(fileName), "\": ", 
       Tcl_PosixError(interp), (char *) NULL);
  return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * SetPermissionsAttribute
 *
 *      Sets the file to the given permission.
 *
 * Results:
 *      Standard TCL result.
 *
 * Side effects:
 *      The permission of the file is changed.
 *      
 *---------------------------------------------------------------------------
 */

static int
SetPermissionsAttribute(interp, objIndex, fileName, attributePtr)
    Tcl_Interp *interp;        /* The interp we are using for errors. */
    int objIndex;        /* The index of the attribute. */
    Tcl_Obj *fileName;        /* The name of the file (UTF-8). */
    Tcl_Obj *attributePtr;      /* The attribute to set. */
{
    long mode;
    mode_t newMode;
    int result;
    CONST char *native;

    /*
     * First try if the string is a number
     */
    if (Tcl_GetLongFromObj(NULL, attributePtr, &mode) == TCL_OK) {
        newMode = (mode_t) (mode & 0x00007FFF);
    } else {
  Tcl_StatBuf buf;
  char *modeStringPtr = Tcl_GetString(attributePtr);

  /*
   * Try the forms "rwxrwxrwx" and "ugo=rwx"
   *
   * We get the current mode of the file, in order to allow for
   * ug+-=rwx style chmod strings.
   */
  result = TclpObjStat(fileName, &buf);
  if (result != 0) {
      Tcl_AppendResult(interp, "could not read \"", 
        Tcl_GetString(fileName), "\": ",
        Tcl_PosixError(interp), (char *) NULL);
      return TCL_ERROR;
  }
  newMode = (mode_t) (buf.st_mode & 0x00007FFF);

  if (GetModeFromPermString(NULL, modeStringPtr, &newMode) != TCL_OK) {
      Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
        "unknown permission string format \"",
        modeStringPtr, "\"", (char *) NULL);
      return TCL_ERROR;
  }
    }

    native = Tcl_FSGetNativePath(fileName);
    result = chmod(native, newMode);    /* INTL: Native. */
    if (result != 0) {
  Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
    "could not set permissions for file \"", 
    Tcl_GetString(fileName), "\": ",
    Tcl_PosixError(interp), (char *) NULL);
  return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpObjListVolumes --
 *
 *  Lists the currently mounted volumes, which on UNIX is just /.
 *
 * Results:
 *  The list of volumes.
 *
 * Side effects:
 *  None.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj*
TclpObjListVolumes(void)
{
    Tcl_Obj *resultPtr = Tcl_NewStringObj("/",1);

    Tcl_IncrRefCount(resultPtr);
    return resultPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * GetModeFromPermString --
 *
 *  This procedure is invoked to process the "file permissions"
 *  Tcl command, to check for a "rwxrwxrwx" or "ugoa+-=rwxst" string.
 *  See the user documentation for details on what it does.
 *
 * Results:
 *  A standard Tcl result.
 *
 * Side effects:
 *  See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
GetModeFromPermString(interp, modeStringPtr, modePtr)
    Tcl_Interp *interp;    /* The interp we are using for errors. */
    char *modeStringPtr;  /* Permissions string */
    mode_t *modePtr;    /* pointer to the mode value */
{
    mode_t newMode;
    mode_t oldMode;    /* Storage for the value of the old mode
         * (that is passed in), to allow for the
         * chmod style manipulation */
    int i,n, who, op, what, op_found, who_found;

    /*
     * We start off checking for an "rwxrwxrwx" style permissions string
     */
    if (strlen(modeStringPtr) != 9) {
        goto chmodStyleCheck;
    }

    newMode = 0;
    for (i = 0; i < 9; i++) {
  switch (*(modeStringPtr+i)) {
      case 'r':
    if ((i%3) != 0) {
        goto chmodStyleCheck;
    }
    newMode |= (1<<(8-i));
    break;
      case 'w':
    if ((i%3) != 1) {
        goto chmodStyleCheck;
    }
    newMode |= (1<<(8-i));
    break;
      case 'x':
    if ((i%3) != 2) {
        goto chmodStyleCheck;
    }
    newMode |= (1<<(8-i));
    break;
      case 's':
    if (((i%3) != 2) || (i > 5)) {
        goto chmodStyleCheck;
    }
    newMode |= (1<<(8-i));
    newMode |= (1<<(11-(i/3)));
    break;
      case 'S':
    if (((i%3) != 2) || (i > 5)) {
        goto chmodStyleCheck;
    }
    newMode |= (1<<(11-(i/3)));
    break;
      case 't':
    if (i != 8) {
        goto chmodStyleCheck;
    }
    newMode |= (1<<(8-i));
    newMode |= (1<<9);
    break;
      case 'T':
    if (i != 8) {
        goto chmodStyleCheck;
    }
    newMode |= (1<<9);
    break;
      case '-':
    break;
      default:
    /*
     * Oops, not what we thought it was, so go on
     */
    goto chmodStyleCheck;
  }
    }
    *modePtr = newMode;
    return TCL_OK;

    chmodStyleCheck:
    /*
     * We now check for an "ugoa+-=rwxst" style permissions string
     */

    for (n = 0 ; *(modeStringPtr+n) != '\0' ; n = n + i) {
  oldMode = *modePtr;
  who = op = what = op_found = who_found = 0;
  for (i = 0 ; *(modeStringPtr+n+i) != '\0' ; i++ ) {
      if (!who_found) {
    /* who */
    switch (*(modeStringPtr+n+i)) {
        case 'u' :
      who |= 0x9c0;
      continue;
        case 'g' :
      who |= 0x438;
      continue;
        case 'o' :
      who |= 0x207;
      continue;
        case 'a' :
      who |= 0xfff;
      continue;
    }
      }
      who_found = 1;
      if (who == 0) {
    who = 0xfff;
      }
      if (!op_found) {
    /* op */
    switch (*(modeStringPtr+n+i)) {
        case '+' :
      op = 1;
      op_found = 1;
      continue;
        case '-' :
      op = 2;
      op_found = 1;
      continue;
        case '=' :
      op = 3;
      op_found = 1;
      continue;
        default  :
      return TCL_ERROR;
    }
      }
      /* what */
      switch (*(modeStringPtr+n+i)) {
    case 'r' :
        what |= 0x124;
        continue;
    case 'w' :
        what |= 0x92;
        continue;
    case 'x' :
        what |= 0x49;
        continue;
    case 's' :
        what |= 0xc00;
        continue;
    case 't' :
        what |= 0x200;
        continue;
    case ',' :
        break;
    default  :
        return TCL_ERROR;
      }
      if (*(modeStringPtr+n+i) == ',') {
    i++;
    break;
      }
  }
  switch (op) {
      case 1 :
    *modePtr = oldMode | (who & what);
    continue;
      case 2 :
    *modePtr = oldMode & ~(who & what);
    continue;
      case 3 :
    *modePtr = (oldMode & ~who) | (who & what);
    continue;
  }
    }
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpObjNormalizePath --
 *
 *  This function scans through a path specification and replaces
 *  it, in place, with a normalized version.  A normalized version
 *  is one in which all symlinks in the path are replaced with
 *  their expanded form (except a symlink at the very end of the
 *  path).
 *
 * Results:
 *  The new 'nextCheckpoint' value, giving as far as we could
 *  understand in the path.
 *
 * Side effects:
 *  The pathPtr string, is modified.
 *
 *---------------------------------------------------------------------------
 */
int
TclpObjNormalizePath(interp, pathPtr, nextCheckpoint)
    Tcl_Interp *interp;
    Tcl_Obj *pathPtr;
    int nextCheckpoint;
{
    char *currentPathEndPosition;
    int pathLen;
    char cur;
    char *path = Tcl_GetStringFromObj(pathPtr, &pathLen);
#ifndef NO_REALPATH
    char normPath[MAXPATHLEN];
    Tcl_DString ds;
    CONST char *nativePath; 
#endif
    /* 
     * We add '1' here because if nextCheckpoint is zero we know
     * that '/' exists, and if it isn't zero, it must point at
     * a directory separator which we also know exists.
     */
    currentPathEndPosition = path + nextCheckpoint;
    if (*currentPathEndPosition == '/') {
  currentPathEndPosition++;
    }

#ifndef NO_REALPATH
    /* For speed, try to get the entire path in one go */
    if (nextCheckpoint == 0) {
        char *lastDir = strrchr(currentPathEndPosition, '/');
  if (lastDir != NULL) {
      nativePath = Tcl_UtfToExternalDString(NULL, path, 
              lastDir - path, &ds);
      if (Realpath(nativePath, normPath) != NULL) {
    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 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;
}



