/*

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

 }