开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > Windows编程 > 通讯编程 > 查看源码
tclUnixFCmd.c
资源名称：ns-allinone-2.33.tar.gz　[点击查看]
上传用户：rrhhcc
上传日期：2015-12-11
资源大小：54129k
文件大小：54k
源码类别：

通讯编程

开发平台：

Visual C++

tclUnixFCmd.c：源码内容
  1. /*
  2.  * tclUnixFCmd.c
  3.  *
  4.  *      This file implements the unix specific portion of file manipulation 
  5.  *      subcommands of the "file" command.  All filename arguments should
  6.  * already be translated to native format.
  7.  *
  8.  * Copyright (c) 1996-1998 Sun Microsystems, Inc.
  9.  *
  10.  * See the file "license.terms" for information on usage and redistribution
  11.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  12.  *
  13.  * RCS: @(#) $Id: tclUnixFCmd.c,v 1.28.2.15 2007/04/29 02:19:51 das Exp $
  14.  *
  15.  * Portions of this code were derived from NetBSD source code which has
  16.  * the following copyright notice:
  17.  *
  18.  * Copyright (c) 1988, 1993, 1994
  19.  *      The Regents of the University of California.  All rights reserved.
  20.  *
  21.  * Redistribution and use in source and binary forms, with or without
  22.  * modification, are permitted provided that the following conditions
  23.  * are met:
  24.  * 1. Redistributions of source code must retain the above copyright
  25.  *    notice, this list of conditions and the following disclaimer.
  26.  * 2. Redistributions in binary form must reproduce the above copyright
  27.  *    notice, this list of conditions and the following disclaimer in the
  28.  *    documentation and/or other materials provided with the distribution.
  29.  * 3. All advertising materials mentioning features or use of this software
  30.  *    must display the following acknowledgement:
  31.  *      This product includes software developed by the University of
  32.  *      California, Berkeley and its contributors.
  33.  * 4. Neither the name of the University nor the names of its contributors
  34.  *    may be used to endorse or promote products derived from this software
  35.  *    without specific prior written permission.
  36.  *
  37.  * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
  38.  * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  39.  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  40.  * ARE DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
  41.  * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  42.  * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
  43.  * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  44.  * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
  45.  * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
  46.  * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
  47.  * SUCH DAMAGE.
  48.  */
  50. #include "tclInt.h"
  51. #include "tclPort.h"
  52. #include <utime.h>
  53. #include <grp.h>
  54. #ifndef HAVE_ST_BLKSIZE
  55. #ifndef NO_FSTATFS
  56. #include <sys/statfs.h>
  57. #endif
  58. #endif
  59. #ifdef HAVE_FTS
  60. #include <fts.h>
  61. #endif
  63. /*
  64.  * The following constants specify the type of callback when
  65.  * TraverseUnixTree() calls the traverseProc()
  66.  */
  68. #define DOTREE_PRED   1     /* pre-order directory  */
  69. #define DOTREE_POSTD  2     /* post-order directory */
  70. #define DOTREE_F      3     /* regular file */
  72. /*
  73.  * Callbacks for file attributes code.
  74.  */
  76. static int GetGroupAttribute _ANSI_ARGS_((Tcl_Interp *interp,
  77.     int objIndex, Tcl_Obj *fileName,
  78.     Tcl_Obj **attributePtrPtr));
  79. static int GetOwnerAttribute _ANSI_ARGS_((Tcl_Interp *interp,
  80.     int objIndex, Tcl_Obj *fileName,
  81.     Tcl_Obj **attributePtrPtr));
  82. static int GetPermissionsAttribute _ANSI_ARGS_((
  83.     Tcl_Interp *interp, int objIndex,
  84.     Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr));
  85. static int SetGroupAttribute _ANSI_ARGS_((Tcl_Interp *interp,
  86.     int objIndex, Tcl_Obj *fileName,
  87.     Tcl_Obj *attributePtr));
  88. static int SetOwnerAttribute _ANSI_ARGS_((Tcl_Interp *interp,
  89.     int objIndex, Tcl_Obj *fileName,
  90.     Tcl_Obj *attributePtr));
  91. static int SetPermissionsAttribute _ANSI_ARGS_((
  92.     Tcl_Interp *interp, int objIndex,
  93.     Tcl_Obj *fileName, Tcl_Obj *attributePtr));
  94. static int GetModeFromPermString _ANSI_ARGS_((
  95.     Tcl_Interp *interp, char *modeStringPtr,
  96.     mode_t *modePtr));
  98. /*
  99.  * Prototype for the TraverseUnixTree callback function.
  100.  */
  102. typedef int (TraversalProc) _ANSI_ARGS_((Tcl_DString *srcPtr,
  103. Tcl_DString *dstPtr, CONST Tcl_StatBuf *statBufPtr, int type,
  104. Tcl_DString *errorPtr));
  106. /*
  107.  * Constants and variables necessary for file attributes subcommand.
  108.  */
  110. enum {
  111.     UNIX_GROUP_ATTRIBUTE,
  112.     UNIX_OWNER_ATTRIBUTE,
  113.     UNIX_PERMISSIONS_ATTRIBUTE
  114. };
  116. CONST char *tclpFileAttrStrings[] = {
  117.     "-group",
  118.     "-owner",
  119.     "-permissions",
  120.     (char *) NULL
  121. };
  123. CONST TclFileAttrProcs tclpFileAttrProcs[] = {
  124.     {GetGroupAttribute, SetGroupAttribute},
  125.     {GetOwnerAttribute, SetOwnerAttribute},
  126.     {GetPermissionsAttribute, SetPermissionsAttribute}
  127. };
  129. /*
  130.  * This is the maximum number of consecutive readdir/unlink calls that can be
  131.  * made (with no intervening rewinddir or closedir/opendir) before triggering
  132.  * a bug that makes readdir return NULL even though some directory entries
  133.  * have not been processed.  The bug afflicts SunOS's readdir when applied to
  134.  * ufs file systems and Darwin 6.5's (and OSX v.10.3.8's) HFS+.  JH found the
  135.  * Darwin readdir to reset at 147, so 130 is chosen to be conservative.  We
  136.  * can't do a general rewind on failure as NFS can create special files that
  137.  * recreate themselves when you try and delete them.  8.4.8 added a solution
  138.  * that was affected by a single such NFS file, this solution should not be
  139.  * affected by less than THRESHOLD such files. [Bug 1034337]
  140.  */
  142. #define MAX_READDIR_UNLINK_THRESHOLD 130
  144. /*
  145.  * Declarations for local procedures defined in this file:
  146.  */
  148. static int CopyFile _ANSI_ARGS_((CONST char *src,
  149.     CONST char *dst, CONST Tcl_StatBuf *statBufPtr));
  150. static int CopyFileAtts _ANSI_ARGS_((CONST char *src,
  151.     CONST char *dst, CONST Tcl_StatBuf *statBufPtr));
  152. static int DoCopyFile _ANSI_ARGS_((CONST char *srcPtr,
  153.     CONST char *dstPtr, CONST Tcl_StatBuf *statBufPtr));
  154. static int DoCreateDirectory _ANSI_ARGS_((CONST char *pathPtr));
  155. static int DoRemoveDirectory _ANSI_ARGS_((Tcl_DString *pathPtr,
  156.     int recursive, Tcl_DString *errorPtr));
  157. static int DoRenameFile _ANSI_ARGS_((CONST char *src,
  158.     CONST char *dst));
  159. static int TraversalCopy _ANSI_ARGS_((Tcl_DString *srcPtr,
  160.     Tcl_DString *dstPtr, CONST Tcl_StatBuf *statBufPtr,
  161.     int type, Tcl_DString *errorPtr));
  162. static int TraversalDelete _ANSI_ARGS_((Tcl_DString *srcPtr,
  163.     Tcl_DString *dstPtr, CONST Tcl_StatBuf *statBufPtr,
  164.     int type, Tcl_DString *errorPtr));
  165. static int TraverseUnixTree _ANSI_ARGS_((
  166.     TraversalProc *traversalProc,
  167.     Tcl_DString *sourcePtr, Tcl_DString *destPtr,
  168.     Tcl_DString *errorPtr, int doRewind));
  170. #ifdef PURIFY
  171. /*
  172.  * realpath and purify don't mix happily.  It has been noted that realpath
  173.  * should not be used with purify because of bogus warnings, but just
  174.  * memset'ing the resolved path will squelch those.  This assumes we are
  175.  * passing the standard MAXPATHLEN size resolved arg.
  176.  */
  177. static char * Realpath _ANSI_ARGS_((CONST char *path,
  178.     char *resolved));
  180. char *
  181. Realpath(path, resolved)
  182.     CONST char *path;
  183.     char *resolved;
  184. {
  185.     memset(resolved, 0, MAXPATHLEN);
  186.     return realpath(path, resolved);
  187. }
  188. #else
  189. #define Realpath realpath
  190. #endif
  192. #ifndef NO_REALPATH
  193. #if defined(__APPLE__) && defined(TCL_THREADS) && 
  194. defined(MAC_OS_X_VERSION_MIN_REQUIRED) && 
  195. MAC_OS_X_VERSION_MIN_REQUIRED < 1030
  196. /*
  197.  * prior to Darwin 7, realpath is not threadsafe, c.f. bug 711232;
  198.  * if we might potentially be running on pre-10.3 OSX,
  199.  * check Darwin release at runtime before using realpath.
  200.  */
  201. extern long tclMacOSXDarwinRelease;
  202. #define haveRealpath (tclMacOSXDarwinRelease >= 7)
  203. #else
  204. #define haveRealpath 1
  205. #endif
  206. #endif /* NO_REALPATH */
  208. #ifdef HAVE_FTS
  209. #ifdef HAVE_STRUCT_STAT64
  210. /* fts doesn't do stat64 */
  211. #define noFtsStat 1
  212. #elif defined(__APPLE__) && defined(__LP64__) && 
  213. defined(MAC_OS_X_VERSION_MIN_REQUIRED) && 
  214. MAC_OS_X_VERSION_MIN_REQUIRED < 1050
  215. /*
  216.  * prior to Darwin 9, 64bit fts_open() without FTS_NOSTAT may crash (due to a
  217.  * 64bit-unsafe ALIGN macro); if we could be running on pre-10.5 OSX, check
  218.  * Darwin release at runtime and do a separate stat() if necessary.
  219.  */
  220. extern long tclMacOSXDarwinRelease;
  221. #define noFtsStat (tclMacOSXDarwinRelease < 9)
  222. #else
  223. #define noFtsStat 0
  224. #endif
  225. #endif /* HAVE_FTS */
  228. /*
  229.  *---------------------------------------------------------------------------
  230.  *
  231.  * TclpObjRenameFile, DoRenameFile --
  232.  *
  233.  *      Changes the name of an existing file or directory, from src to dst.
  234.  * If src and dst refer to the same file or directory, does nothing
  235.  * and returns success.  Otherwise if dst already exists, it will be
  236.  * deleted and replaced by src subject to the following conditions:
  237.  *     If src is a directory, dst may be an empty directory.
  238.  *     If src is a file, dst may be a file.
  239.  * In any other situation where dst already exists, the rename will
  240.  * fail.  
  241.  *
  242.  * Results:
  243.  * If the directory was successfully created, returns TCL_OK.
  244.  * Otherwise the return value is TCL_ERROR and errno is set to
  245.  * indicate the error.  Some possible values for errno are:
  246.  *
  247.  * EACCES:     src or dst parent directory can't be read and/or written.
  248.  * EEXIST:     dst is a non-empty directory.
  249.  * EINVAL:     src is a root directory or dst is a subdirectory of src.
  250.  * EISDIR:     dst is a directory, but src is not.
  251.  * ENOENT:     src doesn't exist, or src or dst is "".
  252.  * ENOTDIR:    src is a directory, but dst is not.  
  253.  * EXDEV:     src and dst are on different filesystems.
  254.  *
  255.  * Side effects:
  256.  * The implementation of rename may allow cross-filesystem renames,
  257.  * but the caller should be prepared to emulate it with copy and
  258.  * delete if errno is EXDEV.
  259.  *
  260.  *---------------------------------------------------------------------------
  261.  */
  263. int 
  264. TclpObjRenameFile(srcPathPtr, destPathPtr)
  265.     Tcl_Obj *srcPathPtr;
  266.     Tcl_Obj *destPathPtr;
  267. {
  268.     return DoRenameFile(Tcl_FSGetNativePath(srcPathPtr), 
  269. Tcl_FSGetNativePath(destPathPtr));
  270. }
  272. static int
  273. DoRenameFile(src, dst)
  274.     CONST char *src; /* Pathname of file or dir to be renamed
  275.  * (native). */
  276.     CONST char *dst; /* New pathname of file or directory
  277.  * (native). */
  278. {
  279.     if (rename(src, dst) == 0) { /* INTL: Native. */
  280. return TCL_OK;
  281.     }
  282.     if (errno == ENOTEMPTY) {
  283. errno = EEXIST;
  284.     }
  286.     /*
  287.      * IRIX returns EIO when you attept to move a directory into
  288.      * itself.  We just map EIO to EINVAL get the right message on SGI.
  289.      * Most platforms don't return EIO except in really strange cases.
  290.      */
  291.     
  292.     if (errno == EIO) {
  293. errno = EINVAL;
  294.     }
  295.     
  296. #ifndef NO_REALPATH
  297.     /*
  298.      * SunOS 4.1.4 reports overwriting a non-empty directory with a
  299.      * directory as EINVAL instead of EEXIST (first rule out the correct
  300.      * EINVAL result code for moving a directory into itself).  Must be
  301.      * conditionally compiled because realpath() not defined on all systems.
  302.      */
  304.     if (errno == EINVAL && haveRealpath) {
  305. char srcPath[MAXPATHLEN], dstPath[MAXPATHLEN];
  306. DIR *dirPtr;
  307. Tcl_DirEntry *dirEntPtr;
  309. if ((Realpath((char *) src, srcPath) != NULL) /* INTL: Native. */
  310. && (Realpath((char *) dst, dstPath) != NULL) /* INTL: Native. */
  311. && (strncmp(srcPath, dstPath, strlen(srcPath)) != 0)) {
  312.     dirPtr = opendir(dst); /* INTL: Native. */
  313.     if (dirPtr != NULL) {
  314. while (1) {
  315.     dirEntPtr = TclOSreaddir(dirPtr); /* INTL: Native. */
  316.     if (dirEntPtr == NULL) {
  317. break;
  318.     }
  319.     if ((strcmp(dirEntPtr->d_name, ".") != 0) &&
  320.     (strcmp(dirEntPtr->d_name, "..") != 0)) {
  321. errno = EEXIST;
  322. closedir(dirPtr);
  323. return TCL_ERROR;
  324.     }
  325. }
  326. closedir(dirPtr);
  327.     }
  328. }
  329. errno = EINVAL;
  330.     }
  331. #endif /* !NO_REALPATH */
  333.     if (strcmp(src, "/") == 0) {
  334. /*
  335.  * Alpha reports renaming / as EBUSY and Linux reports it as EACCES,
  336.  * instead of EINVAL.
  337.  */
  338.  
  339. errno = EINVAL;
  340.     }
  342.     /*
  343.      * DEC Alpha OSF1 V3.0 returns EACCES when attempting to move a
  344.      * file across filesystems and the parent directory of that file is
  345.      * not writable.  Most other systems return EXDEV.  Does nothing to
  346.      * correct this behavior.
  347.      */
  349.     return TCL_ERROR;
  350. }
  352. /*
  353.  *---------------------------------------------------------------------------
  354.  *
  355.  * TclpObjCopyFile, DoCopyFile --
  356.  *
  357.  *      Copy a single file (not a directory).  If dst already exists and
  358.  * is not a directory, it is removed.
  359.  *
  360.  * Results:
  361.  * If the file was successfully copied, returns TCL_OK.  Otherwise
  362.  * the return value is TCL_ERROR and errno is set to indicate the
  363.  * error.  Some possible values for errno are:
  364.  *
  365.  * EACCES:     src or dst parent directory can't be read and/or written.
  366.  * EISDIR:     src or dst is a directory.
  367.  * ENOENT:     src doesn't exist.  src or dst is "".
  368.  *
  369.  * Side effects:
  370.  *      This procedure will also copy symbolic links, block, and
  371.  *      character devices, and fifos.  For symbolic links, the links 
  372.  *      themselves will be copied and not what they point to.  For the
  373.  * other special file types, the directory entry will be copied and
  374.  * not the contents of the device that it refers to.
  375.  *
  376.  *---------------------------------------------------------------------------
  377.  */
  379. int 
  380. TclpObjCopyFile(srcPathPtr, destPathPtr)
  381.     Tcl_Obj *srcPathPtr;
  382.     Tcl_Obj *destPathPtr;
  383. {
  384.     CONST char *src = Tcl_FSGetNativePath(srcPathPtr);
  385.     Tcl_StatBuf srcStatBuf;
  387.     if (TclOSlstat(src, &srcStatBuf) != 0) { /* INTL: Native. */
  388. return TCL_ERROR;
  389.     }
  391.     return DoCopyFile(src, Tcl_FSGetNativePath(destPathPtr), &srcStatBuf);
  392. }
  394. static int
  395. DoCopyFile(src, dst, statBufPtr)
  396.     CONST char *src; /* Pathname of file to be copied (native). */
  397.     CONST char *dst; /* Pathname of file to copy to (native). */
  398.     CONST Tcl_StatBuf *statBufPtr;
  399. /* Used to determine filetype. */
  400. {
  401.     Tcl_StatBuf dstStatBuf;
  403.     if (S_ISDIR(statBufPtr->st_mode)) {
  404. errno = EISDIR;
  405. return TCL_ERROR;
  406.     }
  408.     /*
  409.      * symlink, and some of the other calls will fail if the target 
  410.      * exists, so we remove it first
  411.      */
  412.     
  413.     if (TclOSlstat(dst, &dstStatBuf) == 0) { /* INTL: Native. */
  414. if (S_ISDIR(dstStatBuf.st_mode)) {
  415.     errno = EISDIR;
  416.     return TCL_ERROR;
  417. }
  418.     }
  419.     if (unlink(dst) != 0) { /* INTL: Native. */
  420. if (errno != ENOENT) {
  421.     return TCL_ERROR;
  422. } 
  423.     }
  425.     switch ((int) (statBufPtr->st_mode & S_IFMT)) {
  426. #ifndef DJGPP
  427.         case S_IFLNK: {
  428.     char link[MAXPATHLEN];
  429.     int length;
  431.     length = readlink(src, link, sizeof(link)); /* INTL: Native. */
  432.     if (length == -1) {
  433. return TCL_ERROR;
  434.     }
  435.     link[length] = '';
  436.     if (symlink(link, dst) < 0) { /* INTL: Native. */
  437. return TCL_ERROR;
  438.     }
  439. #ifdef HAVE_COPYFILE
  440. #ifdef WEAK_IMPORT_COPYFILE
  441.     if (copyfile != NULL)
  442. #endif
  443.     copyfile(src, dst, NULL, COPYFILE_XATTR|COPYFILE_NOFOLLOW_SRC);
  444. #endif
  445.     break;
  446. }
  447. #endif
  448.         case S_IFBLK:
  449.         case S_IFCHR: {
  450.     if (mknod(dst, statBufPtr->st_mode, /* INTL: Native. */
  451.     statBufPtr->st_rdev) < 0) {
  452. return TCL_ERROR;
  453.     }
  454.     return CopyFileAtts(src, dst, statBufPtr);
  455. }
  456.         case S_IFIFO: {
  457.     if (mkfifo(dst, statBufPtr->st_mode) < 0) { /* INTL: Native. */
  458. return TCL_ERROR;
  459.     }
  460.     return CopyFileAtts(src, dst, statBufPtr);
  461. }
  462.         default: {
  463.     return CopyFile(src, dst, statBufPtr);
  464. }
  465.     }
  466.     return TCL_OK;
  467. }
  469. /*
  470.  *----------------------------------------------------------------------
  471.  *
  472.  * CopyFile - 
  473.  *
  474.  *      Helper function for TclpCopyFile.  Copies one regular file,
  475.  * using read() and write().
  476.  *
  477.  * Results:
  478.  * A standard Tcl result.
  479.  *
  480.  * Side effects:
  481.  *      A file is copied.  Dst will be overwritten if it exists.
  482.  *
  483.  *----------------------------------------------------------------------
  484.  */
  486. static int 
  487. CopyFile(src, dst, statBufPtr) 
  488.     CONST char *src; /* Pathname of file to copy (native). */
  489.     CONST char *dst; /* Pathname of file to create/overwrite
  490.  * (native). */
  491.     CONST Tcl_StatBuf *statBufPtr;
  492. /* Used to determine mode and blocksize. */
  493. {
  494.     int srcFd;
  495.     int dstFd;
  496.     unsigned blockSize; /* Optimal I/O blocksize for filesystem */
  497.     char *buffer; /* Data buffer for copy */
  498.     size_t nread;
  500.     if ((srcFd = TclOSopen(src, O_RDONLY, 0)) < 0) { /* INTL: Native. */
  501. return TCL_ERROR;
  502.     }
  504.     dstFd = TclOSopen(dst, O_CREAT|O_TRUNC|O_WRONLY, /* INTL: Native. */
  505.     statBufPtr->st_mode);
  506.     if (dstFd < 0) {
  507. close(srcFd); 
  508. return TCL_ERROR;
  509.     }
  511. #ifdef HAVE_ST_BLKSIZE
  512.     blockSize = statBufPtr->st_blksize;
  513. #else
  514. #ifndef NO_FSTATFS
  515.     {
  516. struct statfs fs;
  517. if (fstatfs(srcFd, &fs, sizeof(fs), 0) == 0) {
  518.     blockSize = fs.f_bsize;
  519. } else {
  520.     blockSize = 4096;
  521. }
  522.     }
  523. #else 
  524.     blockSize = 4096;
  525. #endif
  526. #endif
  528.     /* [SF Tcl Bug 1586470] Even if we HAVE_ST_BLKSIZE, there are
  529.      * filesystems which report a bogus value for the blocksize.  An
  530.      * example is the Andrew Filesystem (afs), reporting a blocksize
  531.      * of 0. When detecting such a situation we now simply fall back
  532.      * to a hardwired default size.
  533.      */
  535.     if (blockSize <= 0) {
  536.         blockSize = 4096;
  537.     }
  538.     buffer = ckalloc(blockSize);
  539.     while (1) {
  540. nread = read(srcFd, buffer, blockSize);
  541. if ((nread == -1) || (nread == 0)) {
  542.     break;
  543. }
  544. if (write(dstFd, buffer, nread) != nread) {
  545.     nread = (size_t) -1;
  546.     break;
  547. }
  548.     }
  550.     ckfree(buffer);
  551.     close(srcFd);
  552.     if ((close(dstFd) != 0) || (nread == -1)) {
  553. unlink(dst); /* INTL: Native. */
  554. return TCL_ERROR;
  555.     }
  556.     if (CopyFileAtts(src, dst, statBufPtr) == TCL_ERROR) {
  557. /*
  558.  * The copy succeeded, but setting the permissions failed, so be in
  559.  * a consistent state, we remove the file that was created by the
  560.  * copy.
  561.  */
  563. unlink(dst); /* INTL: Native. */
  564. return TCL_ERROR;
  565.     }
  566.     return TCL_OK;
  567. }
  569. /*
  570.  *---------------------------------------------------------------------------
  571.  *
  572.  * TclpObjDeleteFile, TclpDeleteFile --
  573.  *
  574.  *      Removes a single file (not a directory).
  575.  *
  576.  * Results:
  577.  * If the file was successfully deleted, returns TCL_OK.  Otherwise
  578.  * the return value is TCL_ERROR and errno is set to indicate the
  579.  * error.  Some possible values for errno are:
  580.  *
  581.  * EACCES:     a parent directory can't be read and/or written.
  582.  * EISDIR:     path is a directory.
  583.  * ENOENT:     path doesn't exist or is "".
  584.  *
  585.  * Side effects:
  586.  *      The file is deleted, even if it is read-only.
  587.  *
  588.  *---------------------------------------------------------------------------
  589.  */
  591. int 
  592. TclpObjDeleteFile(pathPtr)
  593.     Tcl_Obj *pathPtr;
  594. {
  595.     return TclpDeleteFile(Tcl_FSGetNativePath(pathPtr));
  596. }
  598. int
  599. TclpDeleteFile(path)
  600.     CONST char *path; /* Pathname of file to be removed (native). */
  601. {
  602.     if (unlink(path) != 0) { /* INTL: Native. */
  603. return TCL_ERROR;
  604.     }
  605.     return TCL_OK;
  606. }
  608. /*
  609.  *---------------------------------------------------------------------------
  610.  *
  611.  * TclpCreateDirectory, DoCreateDirectory --
  612.  *
  613.  *      Creates the specified directory.  All parent directories of the
  614.  * specified directory must already exist.  The directory is
  615.  * automatically created with permissions so that user can access
  616.  * the new directory and create new files or subdirectories in it.
  617.  *
  618.  * Results:
  619.  * If the directory was successfully created, returns TCL_OK.
  620.  * Otherwise the return value is TCL_ERROR and errno is set to
  621.  * indicate the error.  Some possible values for errno are:
  622.  *
  623.  * EACCES:     a parent directory can't be read and/or written.
  624.  * EEXIST:     path already exists.
  625.  * ENOENT:     a parent directory doesn't exist.
  626.  *
  627.  * Side effects:
  628.  *      A directory is created with the current umask, except that
  629.  * permission for u+rwx will always be added.
  630.  *
  631.  *---------------------------------------------------------------------------
  632.  */
  634. int 
  635. TclpObjCreateDirectory(pathPtr)
  636.     Tcl_Obj *pathPtr;
  637. {
  638.     return DoCreateDirectory(Tcl_FSGetNativePath(pathPtr));
  639. }
  641. static int
  642. DoCreateDirectory(path)
  643.     CONST char *path; /* Pathname of directory to create (native). */
  644. {
  645.     mode_t mode;
  647.     mode = umask(0);
  648.     umask(mode);
  650.     /*
  651.      * umask return value is actually the inverse of the permissions.
  652.      */
  654.     mode = (0777 & ~mode) | S_IRUSR | S_IWUSR | S_IXUSR;
  656.     if (mkdir(path, mode) != 0) { /* INTL: Native. */
  657. return TCL_ERROR;
  658.     }
  659.     return TCL_OK;
  660. }
  662. /*
  663.  *---------------------------------------------------------------------------
  664.  *
  665.  * TclpObjCopyDirectory --
  666.  *
  667.  *      Recursively copies a directory.  The target directory dst must
  668.  * not already exist.  Note that this function does not merge two
  669.  * directory hierarchies, even if the target directory is an an
  670.  * empty directory.
  671.  *
  672.  * Results:
  673.  * If the directory was successfully copied, returns TCL_OK.
  674.  * Otherwise the return value is TCL_ERROR, errno is set to indicate
  675.  * the error, and the pathname of the file that caused the error
  676.  * is stored in errorPtr.  See TclpObjCreateDirectory and 
  677.  * TclpObjCopyFile for a description of possible values for errno.
  678.  *
  679.  * Side effects:
  680.  *      An exact copy of the directory hierarchy src will be created
  681.  * with the name dst.  If an error occurs, the error will
  682.  *      be returned immediately, and remaining files will not be
  683.  * processed.
  684.  *
  685.  *---------------------------------------------------------------------------
  686.  */
  688. int 
  689. TclpObjCopyDirectory(srcPathPtr, destPathPtr, errorPtr)
  690.     Tcl_Obj *srcPathPtr;
  691.     Tcl_Obj *destPathPtr;
  692.     Tcl_Obj **errorPtr;
  693. {
  694.     Tcl_DString ds;
  695.     Tcl_DString srcString, dstString;
  696.     int ret;
  697.     Tcl_Obj *transPtr;
  698.     
  699.     transPtr = Tcl_FSGetTranslatedPath(NULL,srcPathPtr);
  700.     Tcl_UtfToExternalDString(NULL, 
  701.      (transPtr != NULL ? Tcl_GetString(transPtr) : NULL), 
  702.      -1, &srcString);
  703.     if (transPtr != NULL) {
  704. Tcl_DecrRefCount(transPtr);
  705.     }
  706.     transPtr = Tcl_FSGetTranslatedPath(NULL,destPathPtr);
  707.     Tcl_UtfToExternalDString(NULL, 
  708.      (transPtr != NULL ? Tcl_GetString(transPtr) : NULL), 
  709.      -1, &dstString);
  710.     if (transPtr != NULL) {
  711. Tcl_DecrRefCount(transPtr);
  712.     }
  714.     ret = TraverseUnixTree(TraversalCopy, &srcString, &dstString, &ds, 0);
  716.     Tcl_DStringFree(&srcString);
  717.     Tcl_DStringFree(&dstString);
  719.     if (ret != TCL_OK) {
  720. *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
  721. Tcl_DStringFree(&ds);
  722. Tcl_IncrRefCount(*errorPtr);
  723.     }
  724.     return ret;
  725. }
  728. /*
  729.  *---------------------------------------------------------------------------
  730.  *
  731.  * TclpRemoveDirectory, DoRemoveDirectory --
  732.  *
  733.  * Removes directory (and its contents, if the recursive flag is set).
  734.  *
  735.  * Results:
  736.  * If the directory was successfully removed, returns TCL_OK.
  737.  * Otherwise the return value is TCL_ERROR, errno is set to indicate
  738.  * the error, and the pathname of the file that caused the error
  739.  * is stored in errorPtr.  Some possible values for errno are:
  740.  *
  741.  * EACCES:     path directory can't be read and/or written.
  742.  * EEXIST:     path is a non-empty directory.
  743.  * EINVAL:     path is a root directory.
  744.  * ENOENT:     path doesn't exist or is "".
  745.  *  ENOTDIR:    path is not a directory.
  746.  *
  747.  * Side effects:
  748.  * Directory removed.  If an error occurs, the error will be returned
  749.  * immediately, and remaining files will not be deleted.
  750.  *
  751.  *---------------------------------------------------------------------------
  752.  */
  753.  
  754. int 
  755. TclpObjRemoveDirectory(pathPtr, recursive, errorPtr)
  756.     Tcl_Obj *pathPtr;
  757.     int recursive;
  758.     Tcl_Obj **errorPtr;
  759. {
  760.     Tcl_DString ds;
  761.     Tcl_DString pathString;
  762.     int ret;
  763.     Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
  765.     Tcl_UtfToExternalDString(NULL, 
  766.      (transPtr != NULL ? Tcl_GetString(transPtr) : NULL), 
  767.      -1, &pathString);
  768.     if (transPtr != NULL) {
  769. Tcl_DecrRefCount(transPtr);
  770.     }
  771.     ret = DoRemoveDirectory(&pathString, recursive, &ds);
  772.     Tcl_DStringFree(&pathString);
  774.     if (ret != TCL_OK) {
  775. *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
  776. Tcl_DStringFree(&ds);
  777. Tcl_IncrRefCount(*errorPtr);
  778.     }
  779.     return ret;
  780. }
  782. static int
  783. DoRemoveDirectory(pathPtr, recursive, errorPtr)
  784.     Tcl_DString *pathPtr; /* Pathname of directory to be removed
  785.  * (native). */
  786.     int recursive; /* If non-zero, removes directories that
  787.  * are nonempty.  Otherwise, will only remove
  788.  * empty directories. */
  789.     Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free
  790.  * DString filled with UTF-8 name of file
  791.  * causing error. */
  792. {
  793.     CONST char *path;
  794.     mode_t oldPerm = 0;
  795.     int result;
  796.     
  797.     path = Tcl_DStringValue(pathPtr);
  798.     
  799.     if (recursive != 0) {
  800. /* We should try to change permissions so this can be deleted */
  801. Tcl_StatBuf statBuf;
  802. int newPerm;
  804. if (TclOSstat(path, &statBuf) == 0) {
  805.     oldPerm = (mode_t) (statBuf.st_mode & 0x00007FFF);
  806. }
  808. newPerm = oldPerm | (64+128+256);
  809. chmod(path, (mode_t) newPerm);
  810.     }
  811.     
  812.     if (rmdir(path) == 0) { /* INTL: Native. */
  813. return TCL_OK;
  814.     }
  815.     if (errno == ENOTEMPTY) {
  816. errno = EEXIST;
  817.     }
  819.     result = TCL_OK;
  820.     if ((errno != EEXIST) || (recursive == 0)) {
  821. if (errorPtr != NULL) {
  822.     Tcl_ExternalToUtfDString(NULL, path, -1, errorPtr);
  823. }
  824. result = TCL_ERROR;
  825.     }
  826.     
  827.     /*
  828.      * The directory is nonempty, but the recursive flag has been
  829.      * specified, so we recursively remove all the files in the directory.
  830.      */
  832.     if (result == TCL_OK) {
  833. result = TraverseUnixTree(TraversalDelete, pathPtr, NULL, errorPtr, 1);
  834.     }
  835.     
  836.     if ((result != TCL_OK) && (recursive != 0)) {
  837.         /* Try to restore permissions */
  838.         chmod(path, oldPerm);
  839.     }
  840.     return result;
  841. }
  843. /*
  844.  *---------------------------------------------------------------------------
  845.  *
  846.  * TraverseUnixTree --
  847.  *
  848.  *      Traverse directory tree specified by sourcePtr, calling the function 
  849.  * traverseProc for each file and directory encountered.  If destPtr 
  850.  * is non-null, each of name in the sourcePtr directory is appended to 
  851.  * the directory specified by destPtr and passed as the second argument 
  852.  * to traverseProc() .
  853.  *
  854.  * Results:
  855.  *      Standard Tcl result.
  856.  *
  857.  * Side effects:
  858.  *      None caused by TraverseUnixTree, however the user specified 
  859.  * traverseProc() may change state.  If an error occurs, the error will
  860.  *      be returned immediately, and remaining files will not be processed.
  861.  *
  862.  *---------------------------------------------------------------------------
  863.  */
  865. static int 
  866. TraverseUnixTree(traverseProc, sourcePtr, targetPtr, errorPtr, doRewind)
  867.     TraversalProc *traverseProc;/* Function to call for every file and
  868.  * directory in source hierarchy. */
  869.     Tcl_DString *sourcePtr; /* Pathname of source directory to be
  870.  * traversed (native). */
  871.     Tcl_DString *targetPtr; /* Pathname of directory to traverse in
  872.  * parallel with source directory (native). */
  873.     Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free
  874.  * DString filled with UTF-8 name of file
  875.  * causing error. */
  876.     int doRewind; /* Flag indicating that to ensure complete
  877.       * traversal of source hierarchy, the readdir
  878.       * loop should be rewound whenever
  879.       * traverseProc has returned TCL_OK; this is
  880.       * required when traverseProc modifies the
  881.       * source hierarchy, e.g. by deleting files. */
  882. {
  883.     Tcl_StatBuf statBuf;
  884.     CONST char *source, *errfile;
  885.     int result, sourceLen;
  886.     int targetLen;
  887. #ifndef HAVE_FTS
  888.     int numProcessed = 0;
  889.     Tcl_DirEntry *dirEntPtr;
  890.     DIR *dirPtr;
  891. #else
  892.     CONST char *paths[2] = {NULL, NULL};
  893.     FTS *fts = NULL;
  894.     FTSENT *ent;
  895. #endif
  897.     errfile = NULL;
  898.     result = TCL_OK;
  899.     targetLen = 0; /* lint. */
  901.     source = Tcl_DStringValue(sourcePtr);
  902.     if (TclOSlstat(source, &statBuf) != 0) { /* INTL: Native. */
  903. errfile = source;
  904. goto end;
  905.     }
  906.     if (!S_ISDIR(statBuf.st_mode)) {
  907. /*
  908.  * Process the regular file
  909.  */
  911. return (*traverseProc)(sourcePtr, targetPtr, &statBuf, DOTREE_F,
  912. errorPtr);
  913.     }
  914. #ifndef HAVE_FTS
  915.     dirPtr = opendir(source); /* INTL: Native. */
  916.     if (dirPtr == NULL) {
  917. /* 
  918.  * Can't read directory
  919.  */
  921. errfile = source;
  922. goto end;
  923.     }
  924.     result = (*traverseProc)(sourcePtr, targetPtr, &statBuf, DOTREE_PRED,
  925.     errorPtr);
  926.     if (result != TCL_OK) {
  927. closedir(dirPtr);
  928. return result;
  929.     }
  931.     Tcl_DStringAppend(sourcePtr, "/", 1);
  932.     sourceLen = Tcl_DStringLength(sourcePtr);
  934.     if (targetPtr != NULL) {
  935. Tcl_DStringAppend(targetPtr, "/", 1);
  936. targetLen = Tcl_DStringLength(targetPtr);
  937.     }
  939.     while ((dirEntPtr = TclOSreaddir(dirPtr)) != NULL) { /* INTL: Native. */
  940. if ((dirEntPtr->d_name[0] == '.')
  941. && ((dirEntPtr->d_name[1] == '')
  942. || (strcmp(dirEntPtr->d_name, "..") == 0))) {
  943.     continue;
  944. }
  946. /*
  947.  * Append name after slash, and recurse on the file.
  948.  */
  950. Tcl_DStringAppend(sourcePtr, dirEntPtr->d_name, -1);
  951. if (targetPtr != NULL) {
  952.     Tcl_DStringAppend(targetPtr, dirEntPtr->d_name, -1);
  953. }
  954. result = TraverseUnixTree(traverseProc, sourcePtr, targetPtr,
  955. errorPtr, doRewind);
  956. if (result != TCL_OK) {
  957.     break;
  958. } else {
  959.     numProcessed++;
  960. }
  962. /*
  963.  * Remove name after slash.
  964.  */
  966. Tcl_DStringSetLength(sourcePtr, sourceLen);
  967. if (targetPtr != NULL) {
  968.     Tcl_DStringSetLength(targetPtr, targetLen);
  969. }
  970. if (doRewind && (numProcessed > MAX_READDIR_UNLINK_THRESHOLD)) {
  971.     /*
  972.      * Call rewinddir if we've called unlink or rmdir so many times
  973.      * (since the opendir or the previous rewinddir), to avoid
  974.      * a NULL-return that may a symptom of a buggy readdir.
  975.      */
  976.     rewinddir(dirPtr);
  977.     numProcessed = 0;
  978. }
  979.     }
  980.     closedir(dirPtr);
  982.     /*
  983.      * Strip off the trailing slash we added
  984.      */
  986.     Tcl_DStringSetLength(sourcePtr, sourceLen - 1);
  987.     if (targetPtr != NULL) {
  988. Tcl_DStringSetLength(targetPtr, targetLen - 1);
  989.     }
  991.     if (result == TCL_OK) {
  992. /*
  993.  * Call traverseProc() on a directory after visiting all the
  994.  * files in that directory.
  995.  */
  997. result = (*traverseProc)(sourcePtr, targetPtr, &statBuf, DOTREE_POSTD,
  998. errorPtr);
  999.     }
  1000. #else /* HAVE_FTS */
  1001.     paths[0] = source;
  1002.     fts = fts_open((char**)paths, FTS_PHYSICAL | FTS_NOCHDIR |
  1003.     (noFtsStat || doRewind ? FTS_NOSTAT : 0),  NULL);
  1004.     if (fts == NULL) {
  1005. errfile = source;
  1006. goto end;
  1007.     }
  1009.     sourceLen = Tcl_DStringLength(sourcePtr);
  1010.     if (targetPtr != NULL) {
  1011. targetLen = Tcl_DStringLength(targetPtr);
  1012.     }
  1014.     while ((ent = fts_read(fts)) != NULL) {
  1015. unsigned short info = ent->fts_info;
  1016. char * path = ent->fts_path + sourceLen;
  1017. unsigned short pathlen = ent->fts_pathlen - sourceLen;
  1018. int type;
  1019. Tcl_StatBuf *statBufPtr = NULL;
  1021. if (info == FTS_DNR || info == FTS_ERR || info == FTS_NS) {
  1022.     errfile = ent->fts_path;
  1023.     break;
  1024. }
  1025. Tcl_DStringAppend(sourcePtr, path, pathlen);
  1026. if (targetPtr != NULL) {
  1027.     Tcl_DStringAppend(targetPtr, path, pathlen);
  1028. }
  1029. switch (info) {
  1030.     case FTS_D:
  1031. type = DOTREE_PRED;
  1032. break;
  1033.     case FTS_DP:
  1034. type = DOTREE_POSTD;
  1035. break;
  1036.     default:
  1037. type = DOTREE_F;
  1038. break;
  1039. }
  1040. if (!doRewind) { /* no need to stat for delete */
  1041.     if (noFtsStat) {
  1042. statBufPtr = &statBuf;
  1043. if (TclOSlstat(ent->fts_path, statBufPtr) != 0) {
  1044.     errfile = ent->fts_path;
  1045.     break;
  1046. }
  1047.     } else {
  1048. statBufPtr = ent->fts_statp;
  1049.     }
  1050. }
  1051. result = (*traverseProc)(sourcePtr, targetPtr, statBufPtr, type,
  1052. errorPtr);
  1053. if (result != TCL_OK) {
  1054.     break;
  1055. }
  1056. Tcl_DStringSetLength(sourcePtr, sourceLen);
  1057. if (targetPtr != NULL) {
  1058.     Tcl_DStringSetLength(targetPtr, targetLen);
  1059. }
  1060.     }
  1061. #endif /* HAVE_FTS */
  1063.     end:
  1064.     if (errfile != NULL) {
  1065. if (errorPtr != NULL) {
  1066.     Tcl_ExternalToUtfDString(NULL, errfile, -1, errorPtr);
  1067. }
  1068. result = TCL_ERROR;
  1069.     }
  1070. #ifdef HAVE_FTS
  1071.     if (fts != NULL) {
  1072. fts_close(fts);
  1073.     }
  1074. #endif /* HAVE_FTS */
  1076.     return result;
  1077. }
  1079. /*
  1080.  *----------------------------------------------------------------------
  1081.  *
  1082.  * TraversalCopy
  1083.  *
  1084.  *      Called from TraverseUnixTree in order to execute a recursive copy
  1085.  *      of a directory.
  1086.  *
  1087.  * Results:
  1088.  *      Standard Tcl result.
  1089.  *
  1090.  * Side effects:
  1091.  *      The file or directory src may be copied to dst, depending on 
  1092.  *      the value of type.
  1093.  *      
  1094.  *----------------------------------------------------------------------
  1095.  */
  1097. static int 
  1098. TraversalCopy(srcPtr, dstPtr, statBufPtr, type, errorPtr) 
  1099.     Tcl_DString *srcPtr; /* Source pathname to copy (native). */
  1100.     Tcl_DString *dstPtr; /* Destination pathname of copy (native). */
  1101.     CONST Tcl_StatBuf *statBufPtr;
  1102. /* Stat info for file specified by srcPtr. */
  1103.     int type;                   /* Reason for call - see TraverseUnixTree(). */
  1104.     Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free
  1105.  * DString filled with UTF-8 name of file
  1106.  * causing error. */
  1107. {
  1108.     switch (type) {
  1109. case DOTREE_F:
  1110.     if (DoCopyFile(Tcl_DStringValue(srcPtr), Tcl_DStringValue(dstPtr),
  1111.     statBufPtr) == TCL_OK) {
  1112. return TCL_OK;
  1113.     }
  1114.     break;
  1116. case DOTREE_PRED:
  1117.     if (DoCreateDirectory(Tcl_DStringValue(dstPtr)) == TCL_OK) {
  1118. return TCL_OK;
  1119.     }
  1120.     break;
  1122. case DOTREE_POSTD:
  1123.     if (CopyFileAtts(Tcl_DStringValue(srcPtr),
  1124.     Tcl_DStringValue(dstPtr), statBufPtr) == TCL_OK) {
  1125. return TCL_OK;
  1126.     }
  1127.     break;
  1129.     }
  1131.     /*
  1132.      * There shouldn't be a problem with src, because we already checked it
  1133.      * to get here.
  1134.      */
  1136.     if (errorPtr != NULL) {
  1137. Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(dstPtr),
  1138. Tcl_DStringLength(dstPtr), errorPtr);
  1139.     }
  1140.     return TCL_ERROR;
  1141. }
  1143. /*
  1144.  *---------------------------------------------------------------------------
  1145.  *
  1146.  * TraversalDelete --
  1147.  *
  1148.  *      Called by procedure TraverseUnixTree for every file and directory
  1149.  * that it encounters in a directory hierarchy. This procedure unlinks
  1150.  *      files, and removes directories after all the containing files 
  1151.  *      have been processed.
  1152.  *
  1153.  * Results:
  1154.  *      Standard Tcl result.
  1155.  *
  1156.  * Side effects:
  1157.  *      Files or directory specified by src will be deleted.
  1158.  *
  1159.  *----------------------------------------------------------------------
  1160.  */
  1162. static int
  1163. TraversalDelete(srcPtr, ignore, statBufPtr, type, errorPtr) 
  1164.     Tcl_DString *srcPtr; /* Source pathname (native). */
  1165.     Tcl_DString *ignore; /* Destination pathname (not used). */
  1166.     CONST Tcl_StatBuf *statBufPtr;
  1167. /* Stat info for file specified by srcPtr. */
  1168.     int type;                   /* Reason for call - see TraverseUnixTree(). */
  1169.     Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free
  1170.  * DString filled with UTF-8 name of file
  1171.  * causing error. */
  1172. {
  1173.     switch (type) {
  1174.         case DOTREE_F: {
  1175.     if (TclpDeleteFile(Tcl_DStringValue(srcPtr)) == 0) {
  1176. return TCL_OK;
  1177.     }
  1178.     break;
  1179. }
  1180.         case DOTREE_PRED: {
  1181.     return TCL_OK;
  1182. }
  1183.         case DOTREE_POSTD: {
  1184.     if (DoRemoveDirectory(srcPtr, 0, NULL) == 0) {
  1185. return TCL_OK;
  1186.     }
  1187.     break;
  1188. }     
  1189.     }
  1190.     if (errorPtr != NULL) {
  1191. Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(srcPtr),
  1192. Tcl_DStringLength(srcPtr), errorPtr);
  1193.     }
  1194.     return TCL_ERROR;
  1195. }
  1197. /*
  1198.  *---------------------------------------------------------------------------
  1199.  *
  1200.  * CopyFileAtts --
  1201.  *
  1202.  * Copy the file attributes such as owner, group, permissions,
  1203.  * and modification date from one file to another.
  1204.  *
  1205.  * Results:
  1206.  * Standard Tcl result.
  1207.  *
  1208.  * Side effects:
  1209.  * user id, group id, permission bits, last modification time, and
  1210.  * last access time are updated in the new file to reflect the
  1211.  * old file.
  1212.  *
  1213.  *---------------------------------------------------------------------------
  1214.  */
  1216. static int
  1217. CopyFileAtts(src, dst, statBufPtr) 
  1218.     CONST char *src; /* Path name of source file (native). */
  1219.     CONST char *dst; /* Path name of target file (native). */
  1220.     CONST Tcl_StatBuf *statBufPtr;
  1221. /* Stat info for source file */
  1222. {
  1223.     struct utimbuf tval;
  1224.     mode_t newMode;
  1225.     
  1226.     newMode = statBufPtr->st_mode
  1227.     & (S_ISUID | S_ISGID | S_IRWXU | S_IRWXG | S_IRWXO);
  1229.     /* 
  1230.      * Note that if you copy a setuid file that is owned by someone
  1231.      * else, and you are not root, then the copy will be setuid to you.
  1232.      * The most correct implementation would probably be to have the
  1233.      * copy not setuid to anyone if the original file was owned by 
  1234.      * someone else, but this corner case isn't currently handled.
  1235.      * It would require another lstat(), or getuid().
  1236.      */
  1237.     
  1238.     if (chmod(dst, newMode)) { /* INTL: Native. */
  1239. newMode &= ~(S_ISUID | S_ISGID);
  1240. if (chmod(dst, newMode)) { /* INTL: Native. */
  1241.     return TCL_ERROR;
  1242. }
  1243.     }
  1245.     tval.actime = statBufPtr->st_atime; 
  1246.     tval.modtime = statBufPtr->st_mtime; 
  1248.     if (utime(dst, &tval)) { /* INTL: Native. */
  1249. return TCL_ERROR;
  1250.     }
  1251. #ifdef HAVE_COPYFILE
  1252. #ifdef WEAK_IMPORT_COPYFILE
  1253.     if (copyfile != NULL)
  1254. #endif
  1255.     copyfile(src, dst, NULL, COPYFILE_XATTR|COPYFILE_ACL);
  1256. #endif
  1257.     return TCL_OK;
  1258. }
  1261. /*
  1262.  *----------------------------------------------------------------------
  1263.  *
  1264.  * GetGroupAttribute
  1265.  *
  1266.  *      Gets the group attribute of a file.
  1267.  *
  1268.  * Results:
  1269.  *      Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr
  1270.  * if there is no error.
  1271.  *
  1272.  * Side effects:
  1273.  *      A new object is allocated.
  1274.  *      
  1275.  *----------------------------------------------------------------------
  1276.  */
  1278. static int
  1279. GetGroupAttribute(interp, objIndex, fileName, attributePtrPtr)
  1280.     Tcl_Interp *interp; /* The interp we are using for errors. */
  1281.     int objIndex; /* The index of the attribute. */
  1282.     Tcl_Obj *fileName;   /* The name of the file (UTF-8). */
  1283.     Tcl_Obj **attributePtrPtr; /* A pointer to return the object with. */
  1284. {
  1285.     Tcl_StatBuf statBuf;
  1286.     struct group *groupPtr;
  1287.     int result;
  1289.     result = TclpObjStat(fileName, &statBuf);
  1290.     
  1291.     if (result != 0) {
  1292. Tcl_AppendResult(interp, "could not read "", 
  1293. Tcl_GetString(fileName), "": ",
  1294. Tcl_PosixError(interp), (char *) NULL);
  1295. return TCL_ERROR;
  1296.     }
  1298.     groupPtr = TclpGetGrGid(statBuf.st_gid);
  1300.     if (result == -1 || groupPtr == NULL) {
  1301. *attributePtrPtr = Tcl_NewIntObj((int) statBuf.st_gid);
  1302.     } else {
  1303. Tcl_DString ds;
  1304. CONST char *utf;
  1306. utf = Tcl_ExternalToUtfDString(NULL, groupPtr->gr_name, -1, &ds); 
  1307. *attributePtrPtr = Tcl_NewStringObj(utf, -1);
  1308. Tcl_DStringFree(&ds);
  1309.     }
  1310.     endgrent();
  1311.     return TCL_OK;
  1312. }
  1314. /*
  1315.  *----------------------------------------------------------------------
  1316.  *
  1317.  * GetOwnerAttribute
  1318.  *
  1319.  *      Gets the owner attribute of a file.
  1320.  *
  1321.  * Results:
  1322.  *      Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr
  1323.  * if there is no error.
  1324.  *
  1325.  * Side effects:
  1326.  *      A new object is allocated.
  1327.  *      
  1328.  *----------------------------------------------------------------------
  1329.  */
  1331. static int
  1332. GetOwnerAttribute(interp, objIndex, fileName, attributePtrPtr)
  1333.     Tcl_Interp *interp; /* The interp we are using for errors. */
  1334.     int objIndex; /* The index of the attribute. */
  1335.     Tcl_Obj *fileName;   /* The name of the file (UTF-8). */
  1336.     Tcl_Obj **attributePtrPtr; /* A pointer to return the object with. */
  1337. {
  1338.     Tcl_StatBuf statBuf;
  1339.     struct passwd *pwPtr;
  1340.     int result;
  1342.     result = TclpObjStat(fileName, &statBuf);
  1343.     
  1344.     if (result != 0) {
  1345. Tcl_AppendResult(interp, "could not read "", 
  1346. Tcl_GetString(fileName), "": ",
  1347. Tcl_PosixError(interp), (char *) NULL);
  1348. return TCL_ERROR;
  1349.     }
  1351.     pwPtr = TclpGetPwUid(statBuf.st_uid);
  1353.     if (result == -1 || pwPtr == NULL) {
  1354. *attributePtrPtr = Tcl_NewIntObj((int) statBuf.st_uid);
  1355.     } else {
  1356. Tcl_DString ds;
  1357. CONST char *utf;
  1359. utf = Tcl_ExternalToUtfDString(NULL, pwPtr->pw_name, -1, &ds); 
  1360. *attributePtrPtr = Tcl_NewStringObj(utf, Tcl_DStringLength(&ds));
  1361. Tcl_DStringFree(&ds);
  1362.     }
  1363.     endpwent();
  1364.     return TCL_OK;
  1365. }
  1367. /*
  1368.  *----------------------------------------------------------------------
  1369.  *
  1370.  * GetPermissionsAttribute
  1371.  *
  1372.  *      Gets the group attribute of a file.
  1373.  *
  1374.  * Results:
  1375.  *      Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr
  1376.  * if there is no error. The object will have ref count 0.
  1377.  *
  1378.  * Side effects:
  1379.  *      A new object is allocated.
  1380.  *      
  1381.  *----------------------------------------------------------------------
  1382.  */
  1384. static int
  1385. GetPermissionsAttribute(interp, objIndex, fileName, attributePtrPtr)
  1386.     Tcl_Interp *interp;     /* The interp we are using for errors. */
  1387.     int objIndex;     /* The index of the attribute. */
  1388.     Tcl_Obj *fileName;       /* The name of the file (UTF-8). */
  1389.     Tcl_Obj **attributePtrPtr;     /* A pointer to return the object with. */
  1390. {
  1391.     Tcl_StatBuf statBuf;
  1392.     char returnString[7];
  1393.     int result;
  1395.     result = TclpObjStat(fileName, &statBuf);
  1396.     
  1397.     if (result != 0) {
  1398. Tcl_AppendResult(interp, "could not read "", 
  1399. Tcl_GetString(fileName), "": ",
  1400. Tcl_PosixError(interp), (char *) NULL);
  1401. return TCL_ERROR;
  1402.     }
  1404.     sprintf(returnString, "%0#5lo", (long) (statBuf.st_mode & 0x00007FFF));
  1406.     *attributePtrPtr = Tcl_NewStringObj(returnString, -1);
  1407.     
  1408.     return TCL_OK;
  1409. }
  1411. /*
  1412.  *---------------------------------------------------------------------------
  1413.  *
  1414.  * SetGroupAttribute --
  1415.  *
  1416.  *      Sets the group of the file to the specified group.
  1417.  *
  1418.  * Results:
  1419.  *      Standard TCL result.
  1420.  *
  1421.  * Side effects:
  1422.  *      As above.
  1423.  *      
  1424.  *---------------------------------------------------------------------------
  1425.  */
  1427. static int
  1428. SetGroupAttribute(interp, objIndex, fileName, attributePtr)
  1429.     Tcl_Interp *interp;     /* The interp for error reporting. */
  1430.     int objIndex;     /* The index of the attribute. */
  1431.     Tcl_Obj *fileName;             /* The name of the file (UTF-8). */
  1432.     Tcl_Obj *attributePtr;     /* New group for file. */
  1433. {
  1434.     long gid;
  1435.     int result;
  1436.     CONST char *native;
  1438.     if (Tcl_GetLongFromObj(NULL, attributePtr, &gid) != TCL_OK) {
  1439. Tcl_DString ds;
  1440. struct group *groupPtr;
  1441. CONST char *string;
  1442. int length;
  1444. string = Tcl_GetStringFromObj(attributePtr, &length);
  1445. native = Tcl_UtfToExternalDString(NULL, string, length, &ds);
  1446. groupPtr = TclpGetGrNam(native); /* INTL: Native. */
  1447. Tcl_DStringFree(&ds);
  1449. if (groupPtr == NULL) {
  1450.     endgrent();
  1451.     Tcl_AppendResult(interp, "could not set group for file "",
  1452.     Tcl_GetString(fileName), "": group "", 
  1453.     string, "" does not exist",
  1454.     (char *) NULL);
  1455.     return TCL_ERROR;
  1456. }
  1457. gid = groupPtr->gr_gid;
  1458.     }
  1460.     native = Tcl_FSGetNativePath(fileName);
  1461.     result = chown(native, (uid_t) -1, (gid_t) gid); /* INTL: Native. */
  1463.     endgrent();
  1464.     if (result != 0) {
  1465. Tcl_AppendResult(interp, "could not set group for file "",
  1466.     Tcl_GetString(fileName), "": ", Tcl_PosixError(interp), 
  1467.     (char *) NULL);
  1468. return TCL_ERROR;
  1469.     }    
  1470.     return TCL_OK;
  1471. }
  1473. /*
  1474.  *---------------------------------------------------------------------------
  1475.  *
  1476.  * SetOwnerAttribute --
  1477.  *
  1478.  *      Sets the owner of the file to the specified owner.
  1479.  *
  1480.  * Results:
  1481.  *      Standard TCL result.
  1482.  *
  1483.  * Side effects:
  1484.  *      As above.
  1485.  *      
  1486.  *---------------------------------------------------------------------------
  1487.  */
  1489. static int
  1490. SetOwnerAttribute(interp, objIndex, fileName, attributePtr)
  1491.     Tcl_Interp *interp;     /* The interp for error reporting. */
  1492.     int objIndex;     /* The index of the attribute. */
  1493.     Tcl_Obj *fileName;        /* The name of the file (UTF-8). */
  1494.     Tcl_Obj *attributePtr;     /* New owner for file. */
  1495. {
  1496.     long uid;
  1497.     int result;
  1498.     CONST char *native;
  1500.     if (Tcl_GetLongFromObj(NULL, attributePtr, &uid) != TCL_OK) {
  1501. Tcl_DString ds;
  1502. struct passwd *pwPtr;
  1503. CONST char *string;
  1504. int length;
  1506. string = Tcl_GetStringFromObj(attributePtr, &length);
  1507. native = Tcl_UtfToExternalDString(NULL, string, length, &ds);
  1508. pwPtr = TclpGetPwNam(native); /* INTL: Native. */
  1509. Tcl_DStringFree(&ds);
  1511. if (pwPtr == NULL) {
  1512.     endpwent();
  1513.     Tcl_AppendResult(interp, "could not set owner for file "",
  1514.      Tcl_GetString(fileName), "": user "", 
  1515.      string, "" does not exist",
  1516.     (char *) NULL);
  1517.     return TCL_ERROR;
  1518. }
  1519. uid = pwPtr->pw_uid;
  1520.     }
  1522.     native = Tcl_FSGetNativePath(fileName);
  1523.     result = chown(native, (uid_t) uid, (gid_t) -1);   /* INTL: Native. */
  1524.     
  1525.     endpwent();
  1526.     if (result != 0) {
  1527. Tcl_AppendResult(interp, "could not set owner for file "", 
  1528.  Tcl_GetString(fileName), "": ", 
  1529.  Tcl_PosixError(interp), (char *) NULL);
  1530. return TCL_ERROR;
  1531.     }
  1532.     return TCL_OK;
  1533. }
  1535. /*
  1536.  *---------------------------------------------------------------------------
  1537.  *
  1538.  * SetPermissionsAttribute
  1539.  *
  1540.  *      Sets the file to the given permission.
  1541.  *
  1542.  * Results:
  1543.  *      Standard TCL result.
  1544.  *
  1545.  * Side effects:
  1546.  *      The permission of the file is changed.
  1547.  *      
  1548.  *---------------------------------------------------------------------------
  1549.  */
  1551. static int
  1552. SetPermissionsAttribute(interp, objIndex, fileName, attributePtr)
  1553.     Tcl_Interp *interp;     /* The interp we are using for errors. */
  1554.     int objIndex;     /* The index of the attribute. */
  1555.     Tcl_Obj *fileName;       /* The name of the file (UTF-8). */
  1556.     Tcl_Obj *attributePtr;     /* The attribute to set. */
  1557. {
  1558.     long mode;
  1559.     mode_t newMode;
  1560.     int result;
  1561.     CONST char *native;
  1563.     /*
  1564.      * First try if the string is a number
  1565.      */
  1566.     if (Tcl_GetLongFromObj(NULL, attributePtr, &mode) == TCL_OK) {
  1567.         newMode = (mode_t) (mode & 0x00007FFF);
  1568.     } else {
  1569. Tcl_StatBuf buf;
  1570. char *modeStringPtr = Tcl_GetString(attributePtr);
  1572. /*
  1573.  * Try the forms "rwxrwxrwx" and "ugo=rwx"
  1574.  *
  1575.  * We get the current mode of the file, in order to allow for
  1576.  * ug+-=rwx style chmod strings.
  1577.  */
  1578. result = TclpObjStat(fileName, &buf);
  1579. if (result != 0) {
  1580.     Tcl_AppendResult(interp, "could not read "", 
  1581.     Tcl_GetString(fileName), "": ",
  1582.     Tcl_PosixError(interp), (char *) NULL);
  1583.     return TCL_ERROR;
  1584. }
  1585. newMode = (mode_t) (buf.st_mode & 0x00007FFF);
  1587. if (GetModeFromPermString(NULL, modeStringPtr, &newMode) != TCL_OK) {
  1588.     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  1589.     "unknown permission string format "",
  1590.     modeStringPtr, """, (char *) NULL);
  1591.     return TCL_ERROR;
  1592. }
  1593.     }
  1595.     native = Tcl_FSGetNativePath(fileName);
  1596.     result = chmod(native, newMode); /* INTL: Native. */
  1597.     if (result != 0) {
  1598. Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  1599. "could not set permissions for file "", 
  1600. Tcl_GetString(fileName), "": ",
  1601. Tcl_PosixError(interp), (char *) NULL);
  1602. return TCL_ERROR;
  1603.     }
  1604.     return TCL_OK;
  1605. }
  1607. /*
  1608.  *---------------------------------------------------------------------------
  1609.  *
  1610.  * TclpObjListVolumes --
  1611.  *
  1612.  * Lists the currently mounted volumes, which on UNIX is just /.
  1613.  *
  1614.  * Results:
  1615.  * The list of volumes.
  1616.  *
  1617.  * Side effects:
  1618.  * None.
  1619.  *
  1620.  *---------------------------------------------------------------------------
  1621.  */
  1623. Tcl_Obj*
  1624. TclpObjListVolumes(void)
  1625. {
  1626.     Tcl_Obj *resultPtr = Tcl_NewStringObj("/",1);
  1628.     Tcl_IncrRefCount(resultPtr);
  1629.     return resultPtr;
  1630. }
  1632. /*
  1633.  *----------------------------------------------------------------------
  1634.  *
  1635.  * GetModeFromPermString --
  1636.  *
  1637.  * This procedure is invoked to process the "file permissions"
  1638.  * Tcl command, to check for a "rwxrwxrwx" or "ugoa+-=rwxst" string.
  1639.  * See the user documentation for details on what it does.
  1640.  *
  1641.  * Results:
  1642.  * A standard Tcl result.
  1643.  *
  1644.  * Side effects:
  1645.  * See the user documentation.
  1646.  *
  1647.  *----------------------------------------------------------------------
  1648.  */
  1650. static int
  1651. GetModeFromPermString(interp, modeStringPtr, modePtr)
  1652.     Tcl_Interp *interp; /* The interp we are using for errors. */
  1653.     char *modeStringPtr; /* Permissions string */
  1654.     mode_t *modePtr; /* pointer to the mode value */
  1655. {
  1656.     mode_t newMode;
  1657.     mode_t oldMode; /* Storage for the value of the old mode
  1658.  * (that is passed in), to allow for the
  1659.  * chmod style manipulation */
  1660.     int i,n, who, op, what, op_found, who_found;
  1662.     /*
  1663.      * We start off checking for an "rwxrwxrwx" style permissions string
  1664.      */
  1665.     if (strlen(modeStringPtr) != 9) {
  1666.         goto chmodStyleCheck;
  1667.     }
  1669.     newMode = 0;
  1670.     for (i = 0; i < 9; i++) {
  1671. switch (*(modeStringPtr+i)) {
  1672.     case 'r':
  1673. if ((i%3) != 0) {
  1674.     goto chmodStyleCheck;
  1675. }
  1676. newMode |= (1<<(8-i));
  1677. break;
  1678.     case 'w':
  1679. if ((i%3) != 1) {
  1680.     goto chmodStyleCheck;
  1681. }
  1682. newMode |= (1<<(8-i));
  1683. break;
  1684.     case 'x':
  1685. if ((i%3) != 2) {
  1686.     goto chmodStyleCheck;
  1687. }
  1688. newMode |= (1<<(8-i));
  1689. break;
  1690.     case 's':
  1691. if (((i%3) != 2) || (i > 5)) {
  1692.     goto chmodStyleCheck;
  1693. }
  1694. newMode |= (1<<(8-i));
  1695. newMode |= (1<<(11-(i/3)));
  1696. break;
  1697.     case 'S':
  1698. if (((i%3) != 2) || (i > 5)) {
  1699.     goto chmodStyleCheck;
  1700. }
  1701. newMode |= (1<<(11-(i/3)));
  1702. break;
  1703.     case 't':
  1704. if (i != 8) {
  1705.     goto chmodStyleCheck;
  1706. }
  1707. newMode |= (1<<(8-i));
  1708. newMode |= (1<<9);
  1709. break;
  1710.     case 'T':
  1711. if (i != 8) {
  1712.     goto chmodStyleCheck;
  1713. }
  1714. newMode |= (1<<9);
  1715. break;
  1716.     case '-':
  1717. break;
  1718.     default:
  1719. /*
  1720.  * Oops, not what we thought it was, so go on
  1721.  */
  1722. goto chmodStyleCheck;
  1723. }
  1724.     }
  1725.     *modePtr = newMode;
  1726.     return TCL_OK;
  1728.     chmodStyleCheck:
  1729.     /*
  1730.      * We now check for an "ugoa+-=rwxst" style permissions string
  1731.      */
  1733.     for (n = 0 ; *(modeStringPtr+n) != '' ; n = n + i) {
  1734. oldMode = *modePtr;
  1735. who = op = what = op_found = who_found = 0;
  1736. for (i = 0 ; *(modeStringPtr+n+i) != '' ; i++ ) {
  1737.     if (!who_found) {
  1738. /* who */
  1739. switch (*(modeStringPtr+n+i)) {
  1740.     case 'u' :
  1741. who |= 0x9c0;
  1742. continue;
  1743.     case 'g' :
  1744. who |= 0x438;
  1745. continue;
  1746.     case 'o' :
  1747. who |= 0x207;
  1748. continue;
  1749.     case 'a' :
  1750. who |= 0xfff;
  1751. continue;
  1752. }
  1753.     }
  1754.     who_found = 1;
  1755.     if (who == 0) {
  1756. who = 0xfff;
  1757.     }
  1758.     if (!op_found) {
  1759. /* op */
  1760. switch (*(modeStringPtr+n+i)) {
  1761.     case '+' :
  1762. op = 1;
  1763. op_found = 1;
  1764. continue;
  1765.     case '-' :
  1766. op = 2;
  1767. op_found = 1;
  1768. continue;
  1769.     case '=' :
  1770. op = 3;
  1771. op_found = 1;
  1772. continue;
  1773.     default  :
  1774. return TCL_ERROR;
  1775. }
  1776.     }
  1777.     /* what */
  1778.     switch (*(modeStringPtr+n+i)) {
  1779. case 'r' :
  1780.     what |= 0x124;
  1781.     continue;
  1782. case 'w' :
  1783.     what |= 0x92;
  1784.     continue;
  1785. case 'x' :
  1786.     what |= 0x49;
  1787.     continue;
  1788. case 's' :
  1789.     what |= 0xc00;
  1790.     continue;
  1791. case 't' :
  1792.     what |= 0x200;
  1793.     continue;
  1794. case ',' :
  1795.     break;
  1796. default  :
  1797.     return TCL_ERROR;
  1798.     }
  1799.     if (*(modeStringPtr+n+i) == ',') {
  1800. i++;
  1801. break;
  1802.     }
  1803. }
  1804. switch (op) {
  1805.     case 1 :
  1806. *modePtr = oldMode | (who & what);
  1807. continue;
  1808.     case 2 :
  1809. *modePtr = oldMode & ~(who & what);
  1810. continue;
  1811.     case 3 :
  1812. *modePtr = (oldMode & ~who) | (who & what);
  1813. continue;
  1814. }
  1815.     }
  1816.     return TCL_OK;
  1817. }
  1819. /*
  1820.  *---------------------------------------------------------------------------
  1821.  *
  1822.  * TclpObjNormalizePath --
  1823.  *
  1824.  * This function scans through a path specification and replaces
  1825.  * it, in place, with a normalized version.  A normalized version
  1826.  * is one in which all symlinks in the path are replaced with
  1827.  * their expanded form (except a symlink at the very end of the
  1828.  * path).
  1829.  *
  1830.  * Results:
  1831.  * The new 'nextCheckpoint' value, giving as far as we could
  1832.  * understand in the path.
  1833.  *
  1834.  * Side effects:
  1835.  * The pathPtr string, is modified.
  1836.  *
  1837.  *---------------------------------------------------------------------------
  1838.  */
  1839. int
  1840. TclpObjNormalizePath(interp, pathPtr, nextCheckpoint)
  1841.     Tcl_Interp *interp;
  1842.     Tcl_Obj *pathPtr;
  1843.     int nextCheckpoint;
  1844. {
  1845.     char *currentPathEndPosition;
  1846.     int pathLen;
  1847.     char cur;
  1848.     char *path = Tcl_GetStringFromObj(pathPtr, &pathLen);
  1849. #ifndef NO_REALPATH
  1850.     char normPath[MAXPATHLEN];
  1851.     Tcl_DString ds;
  1852.     CONST char *nativePath; 
  1853. #endif
  1854.     /* 
  1855.      * We add '1' here because if nextCheckpoint is zero we know
  1856.      * that '/' exists, and if it isn't zero, it must point at
  1857.      * a directory separator which we also know exists.
  1858.      */
  1859.     currentPathEndPosition = path + nextCheckpoint;
  1860.     if (*currentPathEndPosition == '/') {
  1861. currentPathEndPosition++;
  1862.     }
  1864. #ifndef NO_REALPATH
  1865.     /* For speed, try to get the entire path in one go */
  1866.     if (nextCheckpoint == 0 && haveRealpath) {
  1867.         char *lastDir = strrchr(currentPathEndPosition, '/');
  1868. if (lastDir != NULL) {
  1869.     nativePath = Tcl_UtfToExternalDString(NULL, path, 
  1870.   lastDir - path, &ds);
  1871.     if (Realpath(nativePath, normPath) != NULL) {
  1872. if (*nativePath != '/' && *normPath == '/') {
  1873.     /*
  1874.      * realpath has transformed a relative path into an
  1875.      * absolute path, we do not know how to handle this.
  1876.      */
  1877. } else {
  1878.     nextCheckpoint = lastDir - path;
  1879.     goto wholeStringOk;
  1880. }
  1881.     }
  1882.     Tcl_DStringFree(&ds);
  1883. }
  1884.     }
  1885.     /* Else do it the slow way */
  1886. #endif
  1887.     
  1888.     while (1) {
  1889. cur = *currentPathEndPosition;
  1890. if ((cur == '/') && (path != currentPathEndPosition)) {
  1891.     /* Reached directory separator */
  1892.     Tcl_DString ds;
  1893.     CONST char *nativePath;
  1894.     int accessOk;
  1896.     nativePath = Tcl_UtfToExternalDString(NULL, path, 
  1897.     currentPathEndPosition - path, &ds);
  1898.     accessOk = access(nativePath, F_OK);
  1899.     Tcl_DStringFree(&ds);
  1900.     if (accessOk != 0) {
  1901. /* File doesn't exist */
  1902. break;
  1903.     }
  1904.     /* Update the acceptable point */
  1905.     nextCheckpoint = currentPathEndPosition - path;
  1906. } else if (cur == 0) {
  1907.     /* Reached end of string */
  1908.     break;
  1909. }
  1910. currentPathEndPosition++;
  1911.     }
  1912.     /* 
  1913.      * We should really now convert this to a canonical path.  We do
  1914.      * that with 'realpath' if we have it available.  Otherwise we could
  1915.      * step through every single path component, checking whether it is a 
  1916.      * symlink, but that would be a lot of work, and most modern OSes 
  1917.      * have 'realpath'.
  1918.      */
  1919. #ifndef NO_REALPATH
  1920.     if (haveRealpath) {
  1921. /* 
  1922.  * If we only had '/foo' or '/' then we never increment nextCheckpoint
  1923.  * and we don't need or want to go through 'Realpath'.  Also, on some
  1924.  * platforms, passing an empty string to 'Realpath' will give us the
  1925.  * normalized pwd, which is not what we want at all!
  1926.  */
  1927. if (nextCheckpoint == 0) return 0;
  1929. nativePath = Tcl_UtfToExternalDString(NULL, path, nextCheckpoint, &ds);
  1930. if (Realpath(nativePath, normPath) != NULL) {
  1931.     int newNormLen;
  1932.     wholeStringOk:
  1933.     newNormLen = strlen(normPath);
  1934.     if ((newNormLen == Tcl_DStringLength(&ds))
  1935.     && (strcmp(normPath, nativePath) == 0)) {
  1936. /* String is unchanged */
  1937. Tcl_DStringFree(&ds);
  1938. if (path[nextCheckpoint] != '') {
  1939.     nextCheckpoint++;
  1940. }
  1941. return nextCheckpoint;
  1942.     }
  1943.     
  1944.     /* 
  1945.      * Free up the native path and put in its place the
  1946.      * converted, normalized path.
  1947.      */
  1948.     Tcl_DStringFree(&ds);
  1949.     Tcl_ExternalToUtfDString(NULL, normPath, (int) newNormLen, &ds);
  1950.     
  1951.     if (path[nextCheckpoint] != '') {
  1952. /* not at end, append remaining path */
  1953. int normLen = Tcl_DStringLength(&ds);
  1954. Tcl_DStringAppend(&ds, path + nextCheckpoint,
  1955. pathLen - nextCheckpoint);
  1956. /* 
  1957.  * We recognise up to and including the directory
  1958.  * separator.
  1959.  */
  1960. nextCheckpoint = normLen + 1;
  1961.     } else {
  1962. /* We recognise the whole string */ 
  1963. nextCheckpoint = Tcl_DStringLength(&ds);
  1964.     }
  1965.     /* 
  1966.      * Overwrite with the normalized path.
  1967.      */
  1968.     Tcl_SetStringObj(pathPtr, Tcl_DStringValue(&ds),
  1969.     Tcl_DStringLength(&ds));
  1970. }
  1971. Tcl_DStringFree(&ds);
  1972.     }
  1973. #endif /* !NO_REALPATH */
  1975.     return nextCheckpoint;
  1976. }