os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/unix/tclUnixFCmd.c
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/unix/tclUnixFCmd.c Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,1993 @@
1.4 +/*
1.5 + * tclUnixFCmd.c
1.6 + *
1.7 + * This file implements the unix specific portion of file manipulation
1.8 + * subcommands of the "file" command. All filename arguments should
1.9 + * already be translated to native format.
1.10 + *
1.11 + * Copyright (c) 1996-1998 Sun Microsystems, Inc.
1.12 + * Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved.
1.13 + *
1.14 + * See the file "license.terms" for information on usage and redistribution
1.15 + * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.16 + *
1.17 + * RCS: @(#) $Id: tclUnixFCmd.c,v 1.28.2.15 2007/04/29 02:19:51 das Exp $
1.18 + *
1.19 + * Portions of this code were derived from NetBSD source code which has
1.20 + * the following copyright notice:
1.21 + *
1.22 + * Copyright (c) 1988, 1993, 1994
1.23 + * The Regents of the University of California. All rights reserved.
1.24 + *
1.25 + * Redistribution and use in source and binary forms, with or without
1.26 + * modification, are permitted provided that the following conditions
1.27 + * are met:
1.28 + * 1. Redistributions of source code must retain the above copyright
1.29 + * notice, this list of conditions and the following disclaimer.
1.30 + * 2. Redistributions in binary form must reproduce the above copyright
1.31 + * notice, this list of conditions and the following disclaimer in the
1.32 + * documentation and/or other materials provided with the distribution.
1.33 + * 3. All advertising materials mentioning features or use of this software
1.34 + * must display the following acknowledgement:
1.35 + * This product includes software developed by the University of
1.36 + * California, Berkeley and its contributors.
1.37 + * 4. Neither the name of the University nor the names of its contributors
1.38 + * may be used to endorse or promote products derived from this software
1.39 + * without specific prior written permission.
1.40 + *
1.41 + * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
1.42 + * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
1.43 + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
1.44 + * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
1.45 + * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
1.46 + * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
1.47 + * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
1.48 + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
1.49 + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
1.50 + * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
1.51 + * SUCH DAMAGE.
1.52 + */
1.53 +
1.54 +#include "tclInt.h"
1.55 +#include "tclPort.h"
1.56 +#include <utime.h>
1.57 +#include <grp.h>
1.58 +#ifndef HAVE_ST_BLKSIZE
1.59 +#ifndef NO_FSTATFS
1.60 +#include <sys/statfs.h>
1.61 +#endif
1.62 +#endif
1.63 +#ifdef HAVE_FTS
1.64 +#include <fts.h>
1.65 +#endif
1.66 +
1.67 +#ifdef __SYMBIAN32__
1.68 +#include "convertPathSlashes.h"
1.69 +void TclPrint1(const char* aFmt, const char* aStr);
1.70 +#endif
1.71 +/*
1.72 + * The following constants specify the type of callback when
1.73 + * TraverseUnixTree() calls the traverseProc()
1.74 + */
1.75 +
1.76 +#define DOTREE_PRED 1 /* pre-order directory */
1.77 +#define DOTREE_POSTD 2 /* post-order directory */
1.78 +#define DOTREE_F 3 /* regular file */
1.79 +
1.80 +/*
1.81 + * Callbacks for file attributes code.
1.82 + */
1.83 +
1.84 +static int GetGroupAttribute _ANSI_ARGS_((Tcl_Interp *interp,
1.85 + int objIndex, Tcl_Obj *fileName,
1.86 + Tcl_Obj **attributePtrPtr));
1.87 +static int GetOwnerAttribute _ANSI_ARGS_((Tcl_Interp *interp,
1.88 + int objIndex, Tcl_Obj *fileName,
1.89 + Tcl_Obj **attributePtrPtr));
1.90 +static int GetPermissionsAttribute _ANSI_ARGS_((
1.91 + Tcl_Interp *interp, int objIndex,
1.92 + Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr));
1.93 +static int SetGroupAttribute _ANSI_ARGS_((Tcl_Interp *interp,
1.94 + int objIndex, Tcl_Obj *fileName,
1.95 + Tcl_Obj *attributePtr));
1.96 +static int SetOwnerAttribute _ANSI_ARGS_((Tcl_Interp *interp,
1.97 + int objIndex, Tcl_Obj *fileName,
1.98 + Tcl_Obj *attributePtr));
1.99 +static int SetPermissionsAttribute _ANSI_ARGS_((
1.100 + Tcl_Interp *interp, int objIndex,
1.101 + Tcl_Obj *fileName, Tcl_Obj *attributePtr));
1.102 +static int GetModeFromPermString _ANSI_ARGS_((
1.103 + Tcl_Interp *interp, char *modeStringPtr,
1.104 + mode_t *modePtr));
1.105 +
1.106 +/*
1.107 + * Prototype for the TraverseUnixTree callback function.
1.108 + */
1.109 +
1.110 +typedef int (TraversalProc) _ANSI_ARGS_((Tcl_DString *srcPtr,
1.111 + Tcl_DString *dstPtr, CONST Tcl_StatBuf *statBufPtr, int type,
1.112 + Tcl_DString *errorPtr));
1.113 +
1.114 +/*
1.115 + * Constants and variables necessary for file attributes subcommand.
1.116 + */
1.117 +
1.118 +enum {
1.119 + UNIX_GROUP_ATTRIBUTE,
1.120 + UNIX_OWNER_ATTRIBUTE,
1.121 + UNIX_PERMISSIONS_ATTRIBUTE
1.122 +};
1.123 +
1.124 +CONST char *tclpFileAttrStrings[] = {
1.125 + "-group",
1.126 + "-owner",
1.127 + "-permissions",
1.128 + (char *) NULL
1.129 +};
1.130 +
1.131 +CONST TclFileAttrProcs tclpFileAttrProcs[] = {
1.132 + {GetGroupAttribute, SetGroupAttribute},
1.133 + {GetOwnerAttribute, SetOwnerAttribute},
1.134 + {GetPermissionsAttribute, SetPermissionsAttribute}
1.135 +};
1.136 +
1.137 +/*
1.138 + * This is the maximum number of consecutive readdir/unlink calls that can be
1.139 + * made (with no intervening rewinddir or closedir/opendir) before triggering
1.140 + * a bug that makes readdir return NULL even though some directory entries
1.141 + * have not been processed. The bug afflicts SunOS's readdir when applied to
1.142 + * ufs file systems and Darwin 6.5's (and OSX v.10.3.8's) HFS+. JH found the
1.143 + * Darwin readdir to reset at 147, so 130 is chosen to be conservative. We
1.144 + * can't do a general rewind on failure as NFS can create special files that
1.145 + * recreate themselves when you try and delete them. 8.4.8 added a solution
1.146 + * that was affected by a single such NFS file, this solution should not be
1.147 + * affected by less than THRESHOLD such files. [Bug 1034337]
1.148 + */
1.149 +
1.150 +#define MAX_READDIR_UNLINK_THRESHOLD 130
1.151 +
1.152 +/*
1.153 + * Declarations for local procedures defined in this file:
1.154 + */
1.155 +
1.156 +static int CopyFile _ANSI_ARGS_((CONST char *src,
1.157 + CONST char *dst, CONST Tcl_StatBuf *statBufPtr));
1.158 +static int CopyFileAtts _ANSI_ARGS_((CONST char *src,
1.159 + CONST char *dst, CONST Tcl_StatBuf *statBufPtr));
1.160 +static int DoCopyFile _ANSI_ARGS_((CONST char *srcPtr,
1.161 + CONST char *dstPtr, CONST Tcl_StatBuf *statBufPtr));
1.162 +static int DoCreateDirectory _ANSI_ARGS_((CONST char *pathPtr));
1.163 +static int DoRemoveDirectory _ANSI_ARGS_((Tcl_DString *pathPtr,
1.164 + int recursive, Tcl_DString *errorPtr));
1.165 +static int DoRenameFile _ANSI_ARGS_((CONST char *src,
1.166 + CONST char *dst));
1.167 +static int TraversalCopy _ANSI_ARGS_((Tcl_DString *srcPtr,
1.168 + Tcl_DString *dstPtr, CONST Tcl_StatBuf *statBufPtr,
1.169 + int type, Tcl_DString *errorPtr));
1.170 +static int TraversalDelete _ANSI_ARGS_((Tcl_DString *srcPtr,
1.171 + Tcl_DString *dstPtr, CONST Tcl_StatBuf *statBufPtr,
1.172 + int type, Tcl_DString *errorPtr));
1.173 +static int TraverseUnixTree _ANSI_ARGS_((
1.174 + TraversalProc *traversalProc,
1.175 + Tcl_DString *sourcePtr, Tcl_DString *destPtr,
1.176 + Tcl_DString *errorPtr, int doRewind));
1.177 +
1.178 +#ifdef PURIFY
1.179 +/*
1.180 + * realpath and purify don't mix happily. It has been noted that realpath
1.181 + * should not be used with purify because of bogus warnings, but just
1.182 + * memset'ing the resolved path will squelch those. This assumes we are
1.183 + * passing the standard MAXPATHLEN size resolved arg.
1.184 + */
1.185 +static char * Realpath _ANSI_ARGS_((CONST char *path,
1.186 + char *resolved));
1.187 +
1.188 +char *
1.189 +Realpath(path, resolved)
1.190 + CONST char *path;
1.191 + char *resolved;
1.192 +{
1.193 + memset(resolved, 0, MAXPATHLEN);
1.194 + return realpath(path, resolved);
1.195 +}
1.196 +#else
1.197 +#define Realpath realpath
1.198 +#endif
1.199 +
1.200 +#ifndef NO_REALPATH
1.201 +#if defined(__APPLE__) && defined(TCL_THREADS) && \
1.202 + defined(MAC_OS_X_VERSION_MIN_REQUIRED) && \
1.203 + MAC_OS_X_VERSION_MIN_REQUIRED < 1030
1.204 +/*
1.205 + * prior to Darwin 7, realpath is not threadsafe, c.f. bug 711232;
1.206 + * if we might potentially be running on pre-10.3 OSX,
1.207 + * check Darwin release at runtime before using realpath.
1.208 + */
1.209 +extern long tclMacOSXDarwinRelease;
1.210 +#define haveRealpath (tclMacOSXDarwinRelease >= 7)
1.211 +#else
1.212 +#define haveRealpath 1
1.213 +#endif
1.214 +#endif /* NO_REALPATH */
1.215 +
1.216 +#ifdef HAVE_FTS
1.217 +#ifdef HAVE_STRUCT_STAT64
1.218 +/* fts doesn't do stat64 */
1.219 +#define noFtsStat 1
1.220 +#elif defined(__APPLE__) && defined(__LP64__) && \
1.221 + defined(MAC_OS_X_VERSION_MIN_REQUIRED) && \
1.222 + MAC_OS_X_VERSION_MIN_REQUIRED < 1050
1.223 +/*
1.224 + * prior to Darwin 9, 64bit fts_open() without FTS_NOSTAT may crash (due to a
1.225 + * 64bit-unsafe ALIGN macro); if we could be running on pre-10.5 OSX, check
1.226 + * Darwin release at runtime and do a separate stat() if necessary.
1.227 + */
1.228 +extern long tclMacOSXDarwinRelease;
1.229 +#define noFtsStat (tclMacOSXDarwinRelease < 9)
1.230 +#else
1.231 +#define noFtsStat 0
1.232 +#endif
1.233 +#endif /* HAVE_FTS */
1.234 +
1.235 +
1.236 +/*
1.237 + *---------------------------------------------------------------------------
1.238 + *
1.239 + * TclpObjRenameFile, DoRenameFile --
1.240 + *
1.241 + * Changes the name of an existing file or directory, from src to dst.
1.242 + * If src and dst refer to the same file or directory, does nothing
1.243 + * and returns success. Otherwise if dst already exists, it will be
1.244 + * deleted and replaced by src subject to the following conditions:
1.245 + * If src is a directory, dst may be an empty directory.
1.246 + * If src is a file, dst may be a file.
1.247 + * In any other situation where dst already exists, the rename will
1.248 + * fail.
1.249 + *
1.250 + * Results:
1.251 + * If the directory was successfully created, returns TCL_OK.
1.252 + * Otherwise the return value is TCL_ERROR and errno is set to
1.253 + * indicate the error. Some possible values for errno are:
1.254 + *
1.255 + * EACCES: src or dst parent directory can't be read and/or written.
1.256 + * EEXIST: dst is a non-empty directory.
1.257 + * EINVAL: src is a root directory or dst is a subdirectory of src.
1.258 + * EISDIR: dst is a directory, but src is not.
1.259 + * ENOENT: src doesn't exist, or src or dst is "".
1.260 + * ENOTDIR: src is a directory, but dst is not.
1.261 + * EXDEV: src and dst are on different filesystems.
1.262 + *
1.263 + * Side effects:
1.264 + * The implementation of rename may allow cross-filesystem renames,
1.265 + * but the caller should be prepared to emulate it with copy and
1.266 + * delete if errno is EXDEV.
1.267 + *
1.268 + *---------------------------------------------------------------------------
1.269 + */
1.270 +
1.271 +int
1.272 +TclpObjRenameFile(srcPathPtr, destPathPtr)
1.273 + Tcl_Obj *srcPathPtr;
1.274 + Tcl_Obj *destPathPtr;
1.275 +{
1.276 + return DoRenameFile(Tcl_FSGetNativePath(srcPathPtr),
1.277 + Tcl_FSGetNativePath(destPathPtr));
1.278 +}
1.279 +
1.280 +static int
1.281 +DoRenameFile(src, dst)
1.282 + CONST char *src; /* Pathname of file or dir to be renamed
1.283 + * (native). */
1.284 + CONST char *dst; /* New pathname of file or directory
1.285 + * (native). */
1.286 +{
1.287 + if (rename(src, dst) == 0) { /* INTL: Native. */
1.288 + return TCL_OK;
1.289 + }
1.290 + if (errno == ENOTEMPTY) {
1.291 + errno = EEXIST;
1.292 + }
1.293 +
1.294 + /*
1.295 + * IRIX returns EIO when you attept to move a directory into
1.296 + * itself. We just map EIO to EINVAL get the right message on SGI.
1.297 + * Most platforms don't return EIO except in really strange cases.
1.298 + */
1.299 +
1.300 + if (errno == EIO) {
1.301 + errno = EINVAL;
1.302 + }
1.303 +
1.304 +#ifndef NO_REALPATH
1.305 + /*
1.306 + * SunOS 4.1.4 reports overwriting a non-empty directory with a
1.307 + * directory as EINVAL instead of EEXIST (first rule out the correct
1.308 + * EINVAL result code for moving a directory into itself). Must be
1.309 + * conditionally compiled because realpath() not defined on all systems.
1.310 + */
1.311 +
1.312 + if (errno == EINVAL && haveRealpath) {
1.313 + char srcPath[MAXPATHLEN], dstPath[MAXPATHLEN];
1.314 + DIR *dirPtr;
1.315 + Tcl_DirEntry *dirEntPtr;
1.316 +
1.317 + if ((Realpath((char *) src, srcPath) != NULL) /* INTL: Native. */
1.318 + && (Realpath((char *) dst, dstPath) != NULL) /* INTL: Native. */
1.319 + && (strncmp(srcPath, dstPath, strlen(srcPath)) != 0)) {
1.320 + dirPtr = opendir(dst); /* INTL: Native. */
1.321 + if (dirPtr != NULL) {
1.322 + while (1) {
1.323 + dirEntPtr = TclOSreaddir(dirPtr); /* INTL: Native. */
1.324 + if (dirEntPtr == NULL) {
1.325 + break;
1.326 + }
1.327 + if ((strcmp(dirEntPtr->d_name, ".") != 0) &&
1.328 + (strcmp(dirEntPtr->d_name, "..") != 0)) {
1.329 + errno = EEXIST;
1.330 + closedir(dirPtr);
1.331 + return TCL_ERROR;
1.332 + }
1.333 + }
1.334 + closedir(dirPtr);
1.335 + }
1.336 + }
1.337 + errno = EINVAL;
1.338 + }
1.339 +#endif /* !NO_REALPATH */
1.340 +
1.341 + if (strcmp(src, "/") == 0) {
1.342 + /*
1.343 + * Alpha reports renaming / as EBUSY and Linux reports it as EACCES,
1.344 + * instead of EINVAL.
1.345 + */
1.346 +
1.347 + errno = EINVAL;
1.348 + }
1.349 +
1.350 + /*
1.351 + * DEC Alpha OSF1 V3.0 returns EACCES when attempting to move a
1.352 + * file across filesystems and the parent directory of that file is
1.353 + * not writable. Most other systems return EXDEV. Does nothing to
1.354 + * correct this behavior.
1.355 + */
1.356 +
1.357 + return TCL_ERROR;
1.358 +}
1.359 +
1.360 +/*
1.361 + *---------------------------------------------------------------------------
1.362 + *
1.363 + * TclpObjCopyFile, DoCopyFile --
1.364 + *
1.365 + * Copy a single file (not a directory). If dst already exists and
1.366 + * is not a directory, it is removed.
1.367 + *
1.368 + * Results:
1.369 + * If the file was successfully copied, returns TCL_OK. Otherwise
1.370 + * the return value is TCL_ERROR and errno is set to indicate the
1.371 + * error. Some possible values for errno are:
1.372 + *
1.373 + * EACCES: src or dst parent directory can't be read and/or written.
1.374 + * EISDIR: src or dst is a directory.
1.375 + * ENOENT: src doesn't exist. src or dst is "".
1.376 + *
1.377 + * Side effects:
1.378 + * This procedure will also copy symbolic links, block, and
1.379 + * character devices, and fifos. For symbolic links, the links
1.380 + * themselves will be copied and not what they point to. For the
1.381 + * other special file types, the directory entry will be copied and
1.382 + * not the contents of the device that it refers to.
1.383 + *
1.384 + *---------------------------------------------------------------------------
1.385 + */
1.386 +
1.387 +int
1.388 +TclpObjCopyFile(srcPathPtr, destPathPtr)
1.389 + Tcl_Obj *srcPathPtr;
1.390 + Tcl_Obj *destPathPtr;
1.391 +{
1.392 + CONST char *src = Tcl_FSGetNativePath(srcPathPtr);
1.393 + Tcl_StatBuf srcStatBuf;
1.394 +
1.395 + if (TclOSlstat(src, &srcStatBuf) != 0) { /* INTL: Native. */
1.396 + return TCL_ERROR;
1.397 + }
1.398 +
1.399 + return DoCopyFile(src, Tcl_FSGetNativePath(destPathPtr), &srcStatBuf);
1.400 +}
1.401 +
1.402 +static int
1.403 +DoCopyFile(src, dst, statBufPtr)
1.404 + CONST char *src; /* Pathname of file to be copied (native). */
1.405 + CONST char *dst; /* Pathname of file to copy to (native). */
1.406 + CONST Tcl_StatBuf *statBufPtr;
1.407 + /* Used to determine filetype. */
1.408 +{
1.409 + Tcl_StatBuf dstStatBuf;
1.410 +
1.411 + if (S_ISDIR(statBufPtr->st_mode)) {
1.412 + errno = EISDIR;
1.413 + return TCL_ERROR;
1.414 + }
1.415 +
1.416 + /*
1.417 + * symlink, and some of the other calls will fail if the target
1.418 + * exists, so we remove it first
1.419 + */
1.420 +
1.421 + if (TclOSlstat(dst, &dstStatBuf) == 0) { /* INTL: Native. */
1.422 + if (S_ISDIR(dstStatBuf.st_mode)) {
1.423 + errno = EISDIR;
1.424 + return TCL_ERROR;
1.425 + }
1.426 + }
1.427 + if (unlink(dst) != 0) { /* INTL: Native. */
1.428 + if (errno != ENOENT) {
1.429 + return TCL_ERROR;
1.430 + }
1.431 + }
1.432 +
1.433 + switch ((int) (statBufPtr->st_mode & S_IFMT)) {
1.434 +#ifndef DJGPP
1.435 + case S_IFLNK: {
1.436 + char link[MAXPATHLEN];
1.437 + int length;
1.438 +
1.439 + length = readlink(src, link, sizeof(link)); /* INTL: Native. */
1.440 + if (length == -1) {
1.441 + return TCL_ERROR;
1.442 + }
1.443 + link[length] = '\0';
1.444 + if (symlink(link, dst) < 0) { /* INTL: Native. */
1.445 + return TCL_ERROR;
1.446 + }
1.447 +#ifdef HAVE_COPYFILE
1.448 +#ifdef WEAK_IMPORT_COPYFILE
1.449 + if (copyfile != NULL)
1.450 +#endif
1.451 + copyfile(src, dst, NULL, COPYFILE_XATTR|COPYFILE_NOFOLLOW_SRC);
1.452 +#endif
1.453 + break;
1.454 + }
1.455 +#endif
1.456 + case S_IFBLK:
1.457 + case S_IFCHR: {
1.458 +#ifdef __SYMBIAN32__
1.459 + // not supported by PIPS
1.460 + return TCL_ERROR;
1.461 +#else
1.462 + if (mknod(dst, statBufPtr->st_mode, /* INTL: Native. */
1.463 + statBufPtr->st_rdev) < 0) {
1.464 + return TCL_ERROR;
1.465 + }
1.466 + return CopyFileAtts(src, dst, statBufPtr);
1.467 +#endif
1.468 + }
1.469 + case S_IFIFO: {
1.470 + if (mkfifo(dst, statBufPtr->st_mode) < 0) { /* INTL: Native. */
1.471 + return TCL_ERROR;
1.472 + }
1.473 + return CopyFileAtts(src, dst, statBufPtr);
1.474 + }
1.475 + default: {
1.476 + return CopyFile(src, dst, statBufPtr);
1.477 + }
1.478 + }
1.479 + return TCL_OK;
1.480 +}
1.481 +
1.482 +/*
1.483 + *----------------------------------------------------------------------
1.484 + *
1.485 + * CopyFile -
1.486 + *
1.487 + * Helper function for TclpCopyFile. Copies one regular file,
1.488 + * using read() and write().
1.489 + *
1.490 + * Results:
1.491 + * A standard Tcl result.
1.492 + *
1.493 + * Side effects:
1.494 + * A file is copied. Dst will be overwritten if it exists.
1.495 + *
1.496 + *----------------------------------------------------------------------
1.497 + */
1.498 +
1.499 +static int
1.500 +CopyFile(src, dst, statBufPtr)
1.501 + CONST char *src; /* Pathname of file to copy (native). */
1.502 + CONST char *dst; /* Pathname of file to create/overwrite
1.503 + * (native). */
1.504 + CONST Tcl_StatBuf *statBufPtr;
1.505 + /* Used to determine mode and blocksize. */
1.506 +{
1.507 + int srcFd;
1.508 + int dstFd;
1.509 + unsigned blockSize; /* Optimal I/O blocksize for filesystem */
1.510 + char *buffer; /* Data buffer for copy */
1.511 + size_t nread;
1.512 +
1.513 + if ((srcFd = TclOSopen(src, O_RDONLY, 0)) < 0) { /* INTL: Native. */
1.514 + return TCL_ERROR;
1.515 + }
1.516 +
1.517 + dstFd = TclOSopen(dst, O_CREAT|O_TRUNC|O_WRONLY, /* INTL: Native. */
1.518 + statBufPtr->st_mode);
1.519 + if (dstFd < 0) {
1.520 + close(srcFd);
1.521 + return TCL_ERROR;
1.522 + }
1.523 +
1.524 +#ifdef HAVE_ST_BLKSIZE
1.525 + blockSize = statBufPtr->st_blksize;
1.526 +#else
1.527 +#ifndef NO_FSTATFS
1.528 + {
1.529 + struct statfs fs;
1.530 + if (fstatfs(srcFd, &fs, sizeof(fs), 0) == 0) {
1.531 + blockSize = fs.f_bsize;
1.532 + } else {
1.533 + blockSize = 4096;
1.534 + }
1.535 + }
1.536 +#else
1.537 + blockSize = 4096;
1.538 +#endif
1.539 +#endif
1.540 +
1.541 + /* [SF Tcl Bug 1586470] Even if we HAVE_ST_BLKSIZE, there are
1.542 + * filesystems which report a bogus value for the blocksize. An
1.543 + * example is the Andrew Filesystem (afs), reporting a blocksize
1.544 + * of 0. When detecting such a situation we now simply fall back
1.545 + * to a hardwired default size.
1.546 + */
1.547 +
1.548 + if (blockSize <= 0) {
1.549 + blockSize = 4096;
1.550 + }
1.551 + buffer = ckalloc(blockSize);
1.552 + while (1) {
1.553 + nread = read(srcFd, buffer, blockSize);
1.554 + if ((nread == (size_t)-1) || (nread == 0)) {
1.555 + break;
1.556 + }
1.557 + if (write(dstFd, buffer, nread) != nread) {
1.558 + nread = (size_t) -1;
1.559 + break;
1.560 + }
1.561 + }
1.562 +
1.563 + ckfree(buffer);
1.564 + close(srcFd);
1.565 + if ((close(dstFd) != 0) || (nread == (size_t)-1)) {
1.566 + unlink(dst); /* INTL: Native. */
1.567 + return TCL_ERROR;
1.568 + }
1.569 + if (CopyFileAtts(src, dst, statBufPtr) == TCL_ERROR) {
1.570 + /*
1.571 + * The copy succeeded, but setting the permissions failed, so be in
1.572 + * a consistent state, we remove the file that was created by the
1.573 + * copy.
1.574 + */
1.575 +
1.576 + unlink(dst); /* INTL: Native. */
1.577 + return TCL_ERROR;
1.578 + }
1.579 + return TCL_OK;
1.580 +}
1.581 +
1.582 +/*
1.583 + *---------------------------------------------------------------------------
1.584 + *
1.585 + * TclpObjDeleteFile, TclpDeleteFile --
1.586 + *
1.587 + * Removes a single file (not a directory).
1.588 + *
1.589 + * Results:
1.590 + * If the file was successfully deleted, returns TCL_OK. Otherwise
1.591 + * the return value is TCL_ERROR and errno is set to indicate the
1.592 + * error. Some possible values for errno are:
1.593 + *
1.594 + * EACCES: a parent directory can't be read and/or written.
1.595 + * EISDIR: path is a directory.
1.596 + * ENOENT: path doesn't exist or is "".
1.597 + *
1.598 + * Side effects:
1.599 + * The file is deleted, even if it is read-only.
1.600 + *
1.601 + *---------------------------------------------------------------------------
1.602 + */
1.603 +
1.604 +int
1.605 +TclpObjDeleteFile(pathPtr)
1.606 + Tcl_Obj *pathPtr;
1.607 +{
1.608 + return TclpDeleteFile(Tcl_FSGetNativePath(pathPtr));
1.609 +}
1.610 +
1.611 +int
1.612 +TclpDeleteFile(path)
1.613 + CONST char *path; /* Pathname of file to be removed (native). */
1.614 +{
1.615 + if (unlink(path) != 0) { /* INTL: Native. */
1.616 + return TCL_ERROR;
1.617 + }
1.618 + return TCL_OK;
1.619 +}
1.620 +
1.621 +/*
1.622 + *---------------------------------------------------------------------------
1.623 + *
1.624 + * TclpCreateDirectory, DoCreateDirectory --
1.625 + *
1.626 + * Creates the specified directory. All parent directories of the
1.627 + * specified directory must already exist. The directory is
1.628 + * automatically created with permissions so that user can access
1.629 + * the new directory and create new files or subdirectories in it.
1.630 + *
1.631 + * Results:
1.632 + * If the directory was successfully created, returns TCL_OK.
1.633 + * Otherwise the return value is TCL_ERROR and errno is set to
1.634 + * indicate the error. Some possible values for errno are:
1.635 + *
1.636 + * EACCES: a parent directory can't be read and/or written.
1.637 + * EEXIST: path already exists.
1.638 + * ENOENT: a parent directory doesn't exist.
1.639 + *
1.640 + * Side effects:
1.641 + * A directory is created with the current umask, except that
1.642 + * permission for u+rwx will always be added.
1.643 + *
1.644 + *---------------------------------------------------------------------------
1.645 + */
1.646 +
1.647 +int
1.648 +TclpObjCreateDirectory(pathPtr)
1.649 + Tcl_Obj *pathPtr;
1.650 +{
1.651 + return DoCreateDirectory(Tcl_FSGetNativePath(pathPtr));
1.652 +}
1.653 +
1.654 +static int
1.655 +DoCreateDirectory(path)
1.656 + CONST char *path; /* Pathname of directory to create (native). */
1.657 +{
1.658 + mode_t mode;
1.659 +
1.660 + mode = umask(0);
1.661 + umask(mode);
1.662 +
1.663 + /*
1.664 + * umask return value is actually the inverse of the permissions.
1.665 + */
1.666 +
1.667 + mode = (0777 & ~mode) | S_IRUSR | S_IWUSR | S_IXUSR;
1.668 +
1.669 + if (mkdir(path, mode) != 0) { /* INTL: Native. */
1.670 + return TCL_ERROR;
1.671 + }
1.672 + return TCL_OK;
1.673 +}
1.674 +
1.675 +/*
1.676 + *---------------------------------------------------------------------------
1.677 + *
1.678 + * TclpObjCopyDirectory --
1.679 + *
1.680 + * Recursively copies a directory. The target directory dst must
1.681 + * not already exist. Note that this function does not merge two
1.682 + * directory hierarchies, even if the target directory is an an
1.683 + * empty directory.
1.684 + *
1.685 + * Results:
1.686 + * If the directory was successfully copied, returns TCL_OK.
1.687 + * Otherwise the return value is TCL_ERROR, errno is set to indicate
1.688 + * the error, and the pathname of the file that caused the error
1.689 + * is stored in errorPtr. See TclpObjCreateDirectory and
1.690 + * TclpObjCopyFile for a description of possible values for errno.
1.691 + *
1.692 + * Side effects:
1.693 + * An exact copy of the directory hierarchy src will be created
1.694 + * with the name dst. If an error occurs, the error will
1.695 + * be returned immediately, and remaining files will not be
1.696 + * processed.
1.697 + *
1.698 + *---------------------------------------------------------------------------
1.699 + */
1.700 +
1.701 +int
1.702 +TclpObjCopyDirectory(srcPathPtr, destPathPtr, errorPtr)
1.703 + Tcl_Obj *srcPathPtr;
1.704 + Tcl_Obj *destPathPtr;
1.705 + Tcl_Obj **errorPtr;
1.706 +{
1.707 + Tcl_DString ds;
1.708 + Tcl_DString srcString, dstString;
1.709 + int ret;
1.710 + Tcl_Obj *transPtr;
1.711 +
1.712 + transPtr = Tcl_FSGetTranslatedPath(NULL,srcPathPtr);
1.713 + Tcl_UtfToExternalDString(NULL,
1.714 + (transPtr != NULL ? Tcl_GetString(transPtr) : NULL),
1.715 + -1, &srcString);
1.716 + if (transPtr != NULL) {
1.717 + Tcl_DecrRefCount(transPtr);
1.718 + }
1.719 + transPtr = Tcl_FSGetTranslatedPath(NULL,destPathPtr);
1.720 + Tcl_UtfToExternalDString(NULL,
1.721 + (transPtr != NULL ? Tcl_GetString(transPtr) : NULL),
1.722 + -1, &dstString);
1.723 + if (transPtr != NULL) {
1.724 + Tcl_DecrRefCount(transPtr);
1.725 + }
1.726 +
1.727 + ret = TraverseUnixTree(TraversalCopy, &srcString, &dstString, &ds, 0);
1.728 +
1.729 + Tcl_DStringFree(&srcString);
1.730 + Tcl_DStringFree(&dstString);
1.731 +
1.732 + if (ret != TCL_OK) {
1.733 + *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
1.734 + Tcl_DStringFree(&ds);
1.735 + Tcl_IncrRefCount(*errorPtr);
1.736 + }
1.737 + return ret;
1.738 +}
1.739 +
1.740 +
1.741 +/*
1.742 + *---------------------------------------------------------------------------
1.743 + *
1.744 + * TclpRemoveDirectory, DoRemoveDirectory --
1.745 + *
1.746 + * Removes directory (and its contents, if the recursive flag is set).
1.747 + *
1.748 + * Results:
1.749 + * If the directory was successfully removed, returns TCL_OK.
1.750 + * Otherwise the return value is TCL_ERROR, errno is set to indicate
1.751 + * the error, and the pathname of the file that caused the error
1.752 + * is stored in errorPtr. Some possible values for errno are:
1.753 + *
1.754 + * EACCES: path directory can't be read and/or written.
1.755 + * EEXIST: path is a non-empty directory.
1.756 + * EINVAL: path is a root directory.
1.757 + * ENOENT: path doesn't exist or is "".
1.758 + * ENOTDIR: path is not a directory.
1.759 + *
1.760 + * Side effects:
1.761 + * Directory removed. If an error occurs, the error will be returned
1.762 + * immediately, and remaining files will not be deleted.
1.763 + *
1.764 + *---------------------------------------------------------------------------
1.765 + */
1.766 +
1.767 +int
1.768 +TclpObjRemoveDirectory(pathPtr, recursive, errorPtr)
1.769 + Tcl_Obj *pathPtr;
1.770 + int recursive;
1.771 + Tcl_Obj **errorPtr;
1.772 +{
1.773 + Tcl_DString ds;
1.774 + Tcl_DString pathString;
1.775 + int ret;
1.776 + Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
1.777 +
1.778 + Tcl_UtfToExternalDString(NULL,
1.779 + (transPtr != NULL ? Tcl_GetString(transPtr) : NULL),
1.780 + -1, &pathString);
1.781 + if (transPtr != NULL) {
1.782 + Tcl_DecrRefCount(transPtr);
1.783 + }
1.784 + ret = DoRemoveDirectory(&pathString, recursive, &ds);
1.785 + Tcl_DStringFree(&pathString);
1.786 +
1.787 + if (ret != TCL_OK) {
1.788 + *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
1.789 + Tcl_DStringFree(&ds);
1.790 + Tcl_IncrRefCount(*errorPtr);
1.791 + }
1.792 + return ret;
1.793 +}
1.794 +
1.795 +static int
1.796 +DoRemoveDirectory(pathPtr, recursive, errorPtr)
1.797 + Tcl_DString *pathPtr; /* Pathname of directory to be removed
1.798 + * (native). */
1.799 + int recursive; /* If non-zero, removes directories that
1.800 + * are nonempty. Otherwise, will only remove
1.801 + * empty directories. */
1.802 + Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free
1.803 + * DString filled with UTF-8 name of file
1.804 + * causing error. */
1.805 +{
1.806 + CONST char *path;
1.807 + mode_t oldPerm = 0;
1.808 + int result;
1.809 +
1.810 + path = Tcl_DStringValue(pathPtr);
1.811 +
1.812 +#ifdef __SYMBIAN32__
1.813 + TclPrint1(" == DoRemoveDirectory() - \"%S\".\n", path);
1.814 +#endif
1.815 +
1.816 + if (recursive != 0) {
1.817 + /* We should try to change permissions so this can be deleted */
1.818 + Tcl_StatBuf statBuf;
1.819 + int newPerm;
1.820 +
1.821 + if (TclOSstat(path, &statBuf) == 0) {
1.822 + oldPerm = (mode_t) (statBuf.st_mode & 0x00007FFF);
1.823 + }
1.824 +
1.825 + newPerm = oldPerm | (64+128+256);
1.826 + chmod(path, (mode_t) newPerm);
1.827 + }
1.828 +
1.829 + if (rmdir(path) == 0) { /* INTL: Native. */
1.830 + return TCL_OK;
1.831 + }
1.832 + if (errno == ENOTEMPTY) {
1.833 + errno = EEXIST;
1.834 + }
1.835 +
1.836 + result = TCL_OK;
1.837 + if ((errno != EEXIST) || (recursive == 0)) {
1.838 + if (errorPtr != NULL) {
1.839 + Tcl_ExternalToUtfDString(NULL, path, -1, errorPtr);
1.840 + }
1.841 + result = TCL_ERROR;
1.842 + }
1.843 +
1.844 + /*
1.845 + * The directory is nonempty, but the recursive flag has been
1.846 + * specified, so we recursively remove all the files in the directory.
1.847 + */
1.848 +
1.849 + if (result == TCL_OK) {
1.850 + result = TraverseUnixTree(TraversalDelete, pathPtr, NULL, errorPtr, 1);
1.851 + }
1.852 +
1.853 + if ((result != TCL_OK) && (recursive != 0)) {
1.854 + /* Try to restore permissions */
1.855 + chmod(path, oldPerm);
1.856 + }
1.857 + return result;
1.858 +}
1.859 +
1.860 +/*
1.861 + *---------------------------------------------------------------------------
1.862 + *
1.863 + * TraverseUnixTree --
1.864 + *
1.865 + * Traverse directory tree specified by sourcePtr, calling the function
1.866 + * traverseProc for each file and directory encountered. If destPtr
1.867 + * is non-null, each of name in the sourcePtr directory is appended to
1.868 + * the directory specified by destPtr and passed as the second argument
1.869 + * to traverseProc() .
1.870 + *
1.871 + * Results:
1.872 + * Standard Tcl result.
1.873 + *
1.874 + * Side effects:
1.875 + * None caused by TraverseUnixTree, however the user specified
1.876 + * traverseProc() may change state. If an error occurs, the error will
1.877 + * be returned immediately, and remaining files will not be processed.
1.878 + *
1.879 + *---------------------------------------------------------------------------
1.880 + */
1.881 +
1.882 +static int
1.883 +TraverseUnixTree(traverseProc, sourcePtr, targetPtr, errorPtr, doRewind)
1.884 + TraversalProc *traverseProc;/* Function to call for every file and
1.885 + * directory in source hierarchy. */
1.886 + Tcl_DString *sourcePtr; /* Pathname of source directory to be
1.887 + * traversed (native). */
1.888 + Tcl_DString *targetPtr; /* Pathname of directory to traverse in
1.889 + * parallel with source directory (native). */
1.890 + Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free
1.891 + * DString filled with UTF-8 name of file
1.892 + * causing error. */
1.893 + int doRewind; /* Flag indicating that to ensure complete
1.894 + * traversal of source hierarchy, the readdir
1.895 + * loop should be rewound whenever
1.896 + * traverseProc has returned TCL_OK; this is
1.897 + * required when traverseProc modifies the
1.898 + * source hierarchy, e.g. by deleting files. */
1.899 +{
1.900 + Tcl_StatBuf statBuf;
1.901 + CONST char *source, *errfile;
1.902 + int result, sourceLen;
1.903 + int targetLen;
1.904 +#ifndef HAVE_FTS
1.905 + int numProcessed = 0;
1.906 + Tcl_DirEntry *dirEntPtr;
1.907 + DIR *dirPtr;
1.908 +#else
1.909 + CONST char *paths[2] = {NULL, NULL};
1.910 + FTS *fts = NULL;
1.911 + FTSENT *ent;
1.912 +#endif
1.913 +
1.914 + errfile = NULL;
1.915 + result = TCL_OK;
1.916 + targetLen = 0; /* lint. */
1.917 +
1.918 + source = Tcl_DStringValue(sourcePtr);
1.919 + if (TclOSlstat(source, &statBuf) != 0) { /* INTL: Native. */
1.920 + errfile = source;
1.921 + goto end;
1.922 + }
1.923 + if (!S_ISDIR(statBuf.st_mode)) {
1.924 + /*
1.925 + * Process the regular file
1.926 + */
1.927 +
1.928 + return (*traverseProc)(sourcePtr, targetPtr, &statBuf, DOTREE_F,
1.929 + errorPtr);
1.930 + }
1.931 +#ifndef HAVE_FTS
1.932 + dirPtr = opendir(source); /* INTL: Native. */
1.933 + if (dirPtr == NULL) {
1.934 + /*
1.935 + * Can't read directory
1.936 + */
1.937 +
1.938 + errfile = source;
1.939 + goto end;
1.940 + }
1.941 + result = (*traverseProc)(sourcePtr, targetPtr, &statBuf, DOTREE_PRED,
1.942 + errorPtr);
1.943 + if (result != TCL_OK) {
1.944 + closedir(dirPtr);
1.945 + return result;
1.946 + }
1.947 +
1.948 + Tcl_DStringAppend(sourcePtr, "/", 1);
1.949 + sourceLen = Tcl_DStringLength(sourcePtr);
1.950 +
1.951 + if (targetPtr != NULL) {
1.952 + Tcl_DStringAppend(targetPtr, "/", 1);
1.953 + targetLen = Tcl_DStringLength(targetPtr);
1.954 + }
1.955 +
1.956 + while ((dirEntPtr = TclOSreaddir(dirPtr)) != NULL) { /* INTL: Native. */
1.957 + if ((dirEntPtr->d_name[0] == '.')
1.958 + && ((dirEntPtr->d_name[1] == '\0')
1.959 + || (strcmp(dirEntPtr->d_name, "..") == 0))) {
1.960 + continue;
1.961 + }
1.962 +
1.963 + /*
1.964 + * Append name after slash, and recurse on the file.
1.965 + */
1.966 +
1.967 + Tcl_DStringAppend(sourcePtr, dirEntPtr->d_name, -1);
1.968 + if (targetPtr != NULL) {
1.969 + Tcl_DStringAppend(targetPtr, dirEntPtr->d_name, -1);
1.970 + }
1.971 + result = TraverseUnixTree(traverseProc, sourcePtr, targetPtr,
1.972 + errorPtr, doRewind);
1.973 + if (result != TCL_OK) {
1.974 + break;
1.975 + } else {
1.976 + numProcessed++;
1.977 + }
1.978 +
1.979 + /*
1.980 + * Remove name after slash.
1.981 + */
1.982 +
1.983 + Tcl_DStringSetLength(sourcePtr, sourceLen);
1.984 + if (targetPtr != NULL) {
1.985 + Tcl_DStringSetLength(targetPtr, targetLen);
1.986 + }
1.987 + if (doRewind && (numProcessed > MAX_READDIR_UNLINK_THRESHOLD)) {
1.988 + /*
1.989 + * Call rewinddir if we've called unlink or rmdir so many times
1.990 + * (since the opendir or the previous rewinddir), to avoid
1.991 + * a NULL-return that may a symptom of a buggy readdir.
1.992 + */
1.993 + rewinddir(dirPtr);
1.994 + numProcessed = 0;
1.995 + }
1.996 + }
1.997 + closedir(dirPtr);
1.998 +
1.999 + /*
1.1000 + * Strip off the trailing slash we added
1.1001 + */
1.1002 +
1.1003 + Tcl_DStringSetLength(sourcePtr, sourceLen - 1);
1.1004 + if (targetPtr != NULL) {
1.1005 + Tcl_DStringSetLength(targetPtr, targetLen - 1);
1.1006 + }
1.1007 +
1.1008 + if (result == TCL_OK) {
1.1009 + /*
1.1010 + * Call traverseProc() on a directory after visiting all the
1.1011 + * files in that directory.
1.1012 + */
1.1013 +
1.1014 + result = (*traverseProc)(sourcePtr, targetPtr, &statBuf, DOTREE_POSTD,
1.1015 + errorPtr);
1.1016 + }
1.1017 +#else /* HAVE_FTS */
1.1018 + paths[0] = source;
1.1019 + fts = fts_open((char**)paths, FTS_PHYSICAL | FTS_NOCHDIR |
1.1020 + (noFtsStat || doRewind ? FTS_NOSTAT : 0), NULL);
1.1021 + if (fts == NULL) {
1.1022 + errfile = source;
1.1023 + goto end;
1.1024 + }
1.1025 +
1.1026 + sourceLen = Tcl_DStringLength(sourcePtr);
1.1027 + if (targetPtr != NULL) {
1.1028 + targetLen = Tcl_DStringLength(targetPtr);
1.1029 + }
1.1030 +
1.1031 + while ((ent = fts_read(fts)) != NULL) {
1.1032 + unsigned short info = ent->fts_info;
1.1033 + char * path = ent->fts_path + sourceLen;
1.1034 + unsigned short pathlen = ent->fts_pathlen - sourceLen;
1.1035 + int type;
1.1036 + Tcl_StatBuf *statBufPtr = NULL;
1.1037 +
1.1038 + if (info == FTS_DNR || info == FTS_ERR || info == FTS_NS) {
1.1039 + errfile = ent->fts_path;
1.1040 + break;
1.1041 + }
1.1042 + Tcl_DStringAppend(sourcePtr, path, pathlen);
1.1043 + if (targetPtr != NULL) {
1.1044 + Tcl_DStringAppend(targetPtr, path, pathlen);
1.1045 + }
1.1046 + switch (info) {
1.1047 + case FTS_D:
1.1048 + type = DOTREE_PRED;
1.1049 + break;
1.1050 + case FTS_DP:
1.1051 + type = DOTREE_POSTD;
1.1052 + break;
1.1053 + default:
1.1054 + type = DOTREE_F;
1.1055 + break;
1.1056 + }
1.1057 + if (!doRewind) { /* no need to stat for delete */
1.1058 + if (noFtsStat) {
1.1059 + statBufPtr = &statBuf;
1.1060 + if (TclOSlstat(ent->fts_path, statBufPtr) != 0) {
1.1061 + errfile = ent->fts_path;
1.1062 + break;
1.1063 + }
1.1064 + } else {
1.1065 + statBufPtr = ent->fts_statp;
1.1066 + }
1.1067 + }
1.1068 + result = (*traverseProc)(sourcePtr, targetPtr, statBufPtr, type,
1.1069 + errorPtr);
1.1070 + if (result != TCL_OK) {
1.1071 + break;
1.1072 + }
1.1073 + Tcl_DStringSetLength(sourcePtr, sourceLen);
1.1074 + if (targetPtr != NULL) {
1.1075 + Tcl_DStringSetLength(targetPtr, targetLen);
1.1076 + }
1.1077 + }
1.1078 +#endif /* HAVE_FTS */
1.1079 +
1.1080 + end:
1.1081 + if (errfile != NULL) {
1.1082 + if (errorPtr != NULL) {
1.1083 + Tcl_ExternalToUtfDString(NULL, errfile, -1, errorPtr);
1.1084 + }
1.1085 + result = TCL_ERROR;
1.1086 + }
1.1087 +#ifdef HAVE_FTS
1.1088 + if (fts != NULL) {
1.1089 + fts_close(fts);
1.1090 + }
1.1091 +#endif /* HAVE_FTS */
1.1092 +
1.1093 + return result;
1.1094 +}
1.1095 +
1.1096 +/*
1.1097 + *----------------------------------------------------------------------
1.1098 + *
1.1099 + * TraversalCopy
1.1100 + *
1.1101 + * Called from TraverseUnixTree in order to execute a recursive copy
1.1102 + * of a directory.
1.1103 + *
1.1104 + * Results:
1.1105 + * Standard Tcl result.
1.1106 + *
1.1107 + * Side effects:
1.1108 + * The file or directory src may be copied to dst, depending on
1.1109 + * the value of type.
1.1110 + *
1.1111 + *----------------------------------------------------------------------
1.1112 + */
1.1113 +
1.1114 +static int
1.1115 +TraversalCopy(srcPtr, dstPtr, statBufPtr, type, errorPtr)
1.1116 + Tcl_DString *srcPtr; /* Source pathname to copy (native). */
1.1117 + Tcl_DString *dstPtr; /* Destination pathname of copy (native). */
1.1118 + CONST Tcl_StatBuf *statBufPtr;
1.1119 + /* Stat info for file specified by srcPtr. */
1.1120 + int type; /* Reason for call - see TraverseUnixTree(). */
1.1121 + Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free
1.1122 + * DString filled with UTF-8 name of file
1.1123 + * causing error. */
1.1124 +{
1.1125 + switch (type) {
1.1126 + case DOTREE_F:
1.1127 + if (DoCopyFile(Tcl_DStringValue(srcPtr), Tcl_DStringValue(dstPtr),
1.1128 + statBufPtr) == TCL_OK) {
1.1129 + return TCL_OK;
1.1130 + }
1.1131 + break;
1.1132 +
1.1133 + case DOTREE_PRED:
1.1134 + if (DoCreateDirectory(Tcl_DStringValue(dstPtr)) == TCL_OK) {
1.1135 + return TCL_OK;
1.1136 + }
1.1137 + break;
1.1138 +
1.1139 + case DOTREE_POSTD:
1.1140 + if (CopyFileAtts(Tcl_DStringValue(srcPtr),
1.1141 + Tcl_DStringValue(dstPtr), statBufPtr) == TCL_OK) {
1.1142 + return TCL_OK;
1.1143 + }
1.1144 + break;
1.1145 +
1.1146 + }
1.1147 +
1.1148 + /*
1.1149 + * There shouldn't be a problem with src, because we already checked it
1.1150 + * to get here.
1.1151 + */
1.1152 +
1.1153 + if (errorPtr != NULL) {
1.1154 + Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(dstPtr),
1.1155 + Tcl_DStringLength(dstPtr), errorPtr);
1.1156 + }
1.1157 + return TCL_ERROR;
1.1158 +}
1.1159 +
1.1160 +/*
1.1161 + *---------------------------------------------------------------------------
1.1162 + *
1.1163 + * TraversalDelete --
1.1164 + *
1.1165 + * Called by procedure TraverseUnixTree for every file and directory
1.1166 + * that it encounters in a directory hierarchy. This procedure unlinks
1.1167 + * files, and removes directories after all the containing files
1.1168 + * have been processed.
1.1169 + *
1.1170 + * Results:
1.1171 + * Standard Tcl result.
1.1172 + *
1.1173 + * Side effects:
1.1174 + * Files or directory specified by src will be deleted.
1.1175 + *
1.1176 + *----------------------------------------------------------------------
1.1177 + */
1.1178 +
1.1179 +static int
1.1180 +TraversalDelete(srcPtr, ignore, statBufPtr, type, errorPtr)
1.1181 + Tcl_DString *srcPtr; /* Source pathname (native). */
1.1182 + Tcl_DString *ignore; /* Destination pathname (not used). */
1.1183 + CONST Tcl_StatBuf *statBufPtr;
1.1184 + /* Stat info for file specified by srcPtr. */
1.1185 + int type; /* Reason for call - see TraverseUnixTree(). */
1.1186 + Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free
1.1187 + * DString filled with UTF-8 name of file
1.1188 + * causing error. */
1.1189 +{
1.1190 + switch (type) {
1.1191 + case DOTREE_F: {
1.1192 + if (TclpDeleteFile(Tcl_DStringValue(srcPtr)) == 0) {
1.1193 + return TCL_OK;
1.1194 + }
1.1195 + break;
1.1196 + }
1.1197 + case DOTREE_PRED: {
1.1198 + return TCL_OK;
1.1199 + }
1.1200 + case DOTREE_POSTD: {
1.1201 + if (DoRemoveDirectory(srcPtr, 0, NULL) == 0) {
1.1202 + return TCL_OK;
1.1203 + }
1.1204 + break;
1.1205 + }
1.1206 + }
1.1207 + if (errorPtr != NULL) {
1.1208 + Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(srcPtr),
1.1209 + Tcl_DStringLength(srcPtr), errorPtr);
1.1210 + }
1.1211 + return TCL_ERROR;
1.1212 +}
1.1213 +
1.1214 +/*
1.1215 + *---------------------------------------------------------------------------
1.1216 + *
1.1217 + * CopyFileAtts --
1.1218 + *
1.1219 + * Copy the file attributes such as owner, group, permissions,
1.1220 + * and modification date from one file to another.
1.1221 + *
1.1222 + * Results:
1.1223 + * Standard Tcl result.
1.1224 + *
1.1225 + * Side effects:
1.1226 + * user id, group id, permission bits, last modification time, and
1.1227 + * last access time are updated in the new file to reflect the
1.1228 + * old file.
1.1229 + *
1.1230 + *---------------------------------------------------------------------------
1.1231 + */
1.1232 +
1.1233 +static int
1.1234 +CopyFileAtts(src, dst, statBufPtr)
1.1235 + CONST char *src; /* Path name of source file (native). */
1.1236 + CONST char *dst; /* Path name of target file (native). */
1.1237 + CONST Tcl_StatBuf *statBufPtr;
1.1238 + /* Stat info for source file */
1.1239 +{
1.1240 + struct utimbuf tval;
1.1241 + mode_t newMode;
1.1242 +
1.1243 + newMode = statBufPtr->st_mode
1.1244 + & (S_ISUID | S_ISGID | S_IRWXU | S_IRWXG | S_IRWXO);
1.1245 +
1.1246 + /*
1.1247 + * Note that if you copy a setuid file that is owned by someone
1.1248 + * else, and you are not root, then the copy will be setuid to you.
1.1249 + * The most correct implementation would probably be to have the
1.1250 + * copy not setuid to anyone if the original file was owned by
1.1251 + * someone else, but this corner case isn't currently handled.
1.1252 + * It would require another lstat(), or getuid().
1.1253 + */
1.1254 +
1.1255 + if (chmod(dst, newMode)) { /* INTL: Native. */
1.1256 + newMode &= ~(S_ISUID | S_ISGID);
1.1257 + if (chmod(dst, newMode)) { /* INTL: Native. */
1.1258 + return TCL_ERROR;
1.1259 + }
1.1260 + }
1.1261 +
1.1262 + tval.actime = statBufPtr->st_atime;
1.1263 + tval.modtime = statBufPtr->st_mtime;
1.1264 +
1.1265 + if (utime(dst, &tval)) { /* INTL: Native. */
1.1266 + return TCL_ERROR;
1.1267 + }
1.1268 +#ifdef HAVE_COPYFILE
1.1269 +#ifdef WEAK_IMPORT_COPYFILE
1.1270 + if (copyfile != NULL)
1.1271 +#endif
1.1272 + copyfile(src, dst, NULL, COPYFILE_XATTR|COPYFILE_ACL);
1.1273 +#endif
1.1274 + return TCL_OK;
1.1275 +}
1.1276 +
1.1277 +
1.1278 +/*
1.1279 + *----------------------------------------------------------------------
1.1280 + *
1.1281 + * GetGroupAttribute
1.1282 + *
1.1283 + * Gets the group attribute of a file.
1.1284 + *
1.1285 + * Results:
1.1286 + * Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr
1.1287 + * if there is no error.
1.1288 + *
1.1289 + * Side effects:
1.1290 + * A new object is allocated.
1.1291 + *
1.1292 + *----------------------------------------------------------------------
1.1293 + */
1.1294 +
1.1295 +static int
1.1296 +GetGroupAttribute(interp, objIndex, fileName, attributePtrPtr)
1.1297 + Tcl_Interp *interp; /* The interp we are using for errors. */
1.1298 + int objIndex; /* The index of the attribute. */
1.1299 + Tcl_Obj *fileName; /* The name of the file (UTF-8). */
1.1300 + Tcl_Obj **attributePtrPtr; /* A pointer to return the object with. */
1.1301 +{
1.1302 + Tcl_StatBuf statBuf;
1.1303 + struct group *groupPtr;
1.1304 + int result;
1.1305 +
1.1306 + result = TclpObjStat(fileName, &statBuf);
1.1307 +
1.1308 + if (result != 0) {
1.1309 + Tcl_AppendResult(interp, "could not read \"",
1.1310 + Tcl_GetString(fileName), "\": ",
1.1311 + Tcl_PosixError(interp), (char *) NULL);
1.1312 + return TCL_ERROR;
1.1313 + }
1.1314 +
1.1315 + groupPtr = TclpGetGrGid(statBuf.st_gid);
1.1316 +
1.1317 + if (result == -1 || groupPtr == NULL) {
1.1318 + *attributePtrPtr = Tcl_NewIntObj((int) statBuf.st_gid);
1.1319 + } else {
1.1320 + Tcl_DString ds;
1.1321 + CONST char *utf;
1.1322 +
1.1323 + utf = Tcl_ExternalToUtfDString(NULL, groupPtr->gr_name, -1, &ds);
1.1324 + *attributePtrPtr = Tcl_NewStringObj(utf, -1);
1.1325 + Tcl_DStringFree(&ds);
1.1326 + }
1.1327 + endgrent();
1.1328 + return TCL_OK;
1.1329 +}
1.1330 +
1.1331 +/*
1.1332 + *----------------------------------------------------------------------
1.1333 + *
1.1334 + * GetOwnerAttribute
1.1335 + *
1.1336 + * Gets the owner attribute of a file.
1.1337 + *
1.1338 + * Results:
1.1339 + * Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr
1.1340 + * if there is no error.
1.1341 + *
1.1342 + * Side effects:
1.1343 + * A new object is allocated.
1.1344 + *
1.1345 + *----------------------------------------------------------------------
1.1346 + */
1.1347 +
1.1348 +static int
1.1349 +GetOwnerAttribute(interp, objIndex, fileName, attributePtrPtr)
1.1350 + Tcl_Interp *interp; /* The interp we are using for errors. */
1.1351 + int objIndex; /* The index of the attribute. */
1.1352 + Tcl_Obj *fileName; /* The name of the file (UTF-8). */
1.1353 + Tcl_Obj **attributePtrPtr; /* A pointer to return the object with. */
1.1354 +{
1.1355 + Tcl_StatBuf statBuf;
1.1356 + struct passwd *pwPtr;
1.1357 + int result;
1.1358 +
1.1359 + result = TclpObjStat(fileName, &statBuf);
1.1360 +
1.1361 + if (result != 0) {
1.1362 + Tcl_AppendResult(interp, "could not read \"",
1.1363 + Tcl_GetString(fileName), "\": ",
1.1364 + Tcl_PosixError(interp), (char *) NULL);
1.1365 + return TCL_ERROR;
1.1366 + }
1.1367 +
1.1368 + pwPtr = TclpGetPwUid(statBuf.st_uid);
1.1369 +
1.1370 + if (result == -1 || pwPtr == NULL) {
1.1371 + *attributePtrPtr = Tcl_NewIntObj((int) statBuf.st_uid);
1.1372 + } else {
1.1373 + Tcl_DString ds;
1.1374 + CONST char *utf;
1.1375 +
1.1376 + utf = Tcl_ExternalToUtfDString(NULL, pwPtr->pw_name, -1, &ds);
1.1377 + *attributePtrPtr = Tcl_NewStringObj(utf, Tcl_DStringLength(&ds));
1.1378 + Tcl_DStringFree(&ds);
1.1379 + }
1.1380 + endpwent();
1.1381 + return TCL_OK;
1.1382 +}
1.1383 +
1.1384 +/*
1.1385 + *----------------------------------------------------------------------
1.1386 + *
1.1387 + * GetPermissionsAttribute
1.1388 + *
1.1389 + * Gets the group attribute of a file.
1.1390 + *
1.1391 + * Results:
1.1392 + * Standard TCL result. Returns a new Tcl_Obj in attributePtrPtr
1.1393 + * if there is no error. The object will have ref count 0.
1.1394 + *
1.1395 + * Side effects:
1.1396 + * A new object is allocated.
1.1397 + *
1.1398 + *----------------------------------------------------------------------
1.1399 + */
1.1400 +
1.1401 +static int
1.1402 +GetPermissionsAttribute(interp, objIndex, fileName, attributePtrPtr)
1.1403 + Tcl_Interp *interp; /* The interp we are using for errors. */
1.1404 + int objIndex; /* The index of the attribute. */
1.1405 + Tcl_Obj *fileName; /* The name of the file (UTF-8). */
1.1406 + Tcl_Obj **attributePtrPtr; /* A pointer to return the object with. */
1.1407 +{
1.1408 + Tcl_StatBuf statBuf;
1.1409 + char returnString[7];
1.1410 + int result;
1.1411 +
1.1412 + result = TclpObjStat(fileName, &statBuf);
1.1413 +
1.1414 + if (result != 0) {
1.1415 + Tcl_AppendResult(interp, "could not read \"",
1.1416 + Tcl_GetString(fileName), "\": ",
1.1417 + Tcl_PosixError(interp), (char *) NULL);
1.1418 + return TCL_ERROR;
1.1419 + }
1.1420 +
1.1421 + sprintf(returnString, "%0#5lo", (long) (statBuf.st_mode & 0x00007FFF));
1.1422 +
1.1423 + *attributePtrPtr = Tcl_NewStringObj(returnString, -1);
1.1424 +
1.1425 + return TCL_OK;
1.1426 +}
1.1427 +
1.1428 +/*
1.1429 + *---------------------------------------------------------------------------
1.1430 + *
1.1431 + * SetGroupAttribute --
1.1432 + *
1.1433 + * Sets the group of the file to the specified group.
1.1434 + *
1.1435 + * Results:
1.1436 + * Standard TCL result.
1.1437 + *
1.1438 + * Side effects:
1.1439 + * As above.
1.1440 + *
1.1441 + *---------------------------------------------------------------------------
1.1442 + */
1.1443 +
1.1444 +static int
1.1445 +SetGroupAttribute(interp, objIndex, fileName, attributePtr)
1.1446 + Tcl_Interp *interp; /* The interp for error reporting. */
1.1447 + int objIndex; /* The index of the attribute. */
1.1448 + Tcl_Obj *fileName; /* The name of the file (UTF-8). */
1.1449 + Tcl_Obj *attributePtr; /* New group for file. */
1.1450 +{
1.1451 + long gid;
1.1452 + int result;
1.1453 + CONST char *native;
1.1454 +
1.1455 + if (Tcl_GetLongFromObj(NULL, attributePtr, &gid) != TCL_OK) {
1.1456 + Tcl_DString ds;
1.1457 + struct group *groupPtr;
1.1458 + CONST char *string;
1.1459 + int length;
1.1460 +
1.1461 + string = Tcl_GetStringFromObj(attributePtr, &length);
1.1462 + native = Tcl_UtfToExternalDString(NULL, string, length, &ds);
1.1463 + groupPtr = TclpGetGrNam(native); /* INTL: Native. */
1.1464 + Tcl_DStringFree(&ds);
1.1465 +
1.1466 + if (groupPtr == NULL) {
1.1467 + endgrent();
1.1468 + Tcl_AppendResult(interp, "could not set group for file \"",
1.1469 + Tcl_GetString(fileName), "\": group \"",
1.1470 + string, "\" does not exist",
1.1471 + (char *) NULL);
1.1472 + return TCL_ERROR;
1.1473 + }
1.1474 + gid = groupPtr->gr_gid;
1.1475 + }
1.1476 +
1.1477 + native = Tcl_FSGetNativePath(fileName);
1.1478 + result = chown(native, (uid_t) -1, (gid_t) gid); /* INTL: Native. */
1.1479 +
1.1480 + endgrent();
1.1481 + if (result != 0) {
1.1482 + Tcl_AppendResult(interp, "could not set group for file \"",
1.1483 + Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp),
1.1484 + (char *) NULL);
1.1485 + return TCL_ERROR;
1.1486 + }
1.1487 + return TCL_OK;
1.1488 +}
1.1489 +
1.1490 +/*
1.1491 + *---------------------------------------------------------------------------
1.1492 + *
1.1493 + * SetOwnerAttribute --
1.1494 + *
1.1495 + * Sets the owner of the file to the specified owner.
1.1496 + *
1.1497 + * Results:
1.1498 + * Standard TCL result.
1.1499 + *
1.1500 + * Side effects:
1.1501 + * As above.
1.1502 + *
1.1503 + *---------------------------------------------------------------------------
1.1504 + */
1.1505 +
1.1506 +static int
1.1507 +SetOwnerAttribute(interp, objIndex, fileName, attributePtr)
1.1508 + Tcl_Interp *interp; /* The interp for error reporting. */
1.1509 + int objIndex; /* The index of the attribute. */
1.1510 + Tcl_Obj *fileName; /* The name of the file (UTF-8). */
1.1511 + Tcl_Obj *attributePtr; /* New owner for file. */
1.1512 +{
1.1513 + long uid;
1.1514 + int result;
1.1515 + CONST char *native;
1.1516 +
1.1517 + if (Tcl_GetLongFromObj(NULL, attributePtr, &uid) != TCL_OK) {
1.1518 + Tcl_DString ds;
1.1519 + struct passwd *pwPtr;
1.1520 + CONST char *string;
1.1521 + int length;
1.1522 +
1.1523 + string = Tcl_GetStringFromObj(attributePtr, &length);
1.1524 + native = Tcl_UtfToExternalDString(NULL, string, length, &ds);
1.1525 + pwPtr = TclpGetPwNam(native); /* INTL: Native. */
1.1526 + Tcl_DStringFree(&ds);
1.1527 +
1.1528 + if (pwPtr == NULL) {
1.1529 + endpwent();
1.1530 + Tcl_AppendResult(interp, "could not set owner for file \"",
1.1531 + Tcl_GetString(fileName), "\": user \"",
1.1532 + string, "\" does not exist",
1.1533 + (char *) NULL);
1.1534 + return TCL_ERROR;
1.1535 + }
1.1536 + uid = pwPtr->pw_uid;
1.1537 + }
1.1538 +
1.1539 + native = Tcl_FSGetNativePath(fileName);
1.1540 + result = chown(native, (uid_t) uid, (gid_t) -1); /* INTL: Native. */
1.1541 +
1.1542 + endpwent();
1.1543 + if (result != 0) {
1.1544 + Tcl_AppendResult(interp, "could not set owner for file \"",
1.1545 + Tcl_GetString(fileName), "\": ",
1.1546 + Tcl_PosixError(interp), (char *) NULL);
1.1547 + return TCL_ERROR;
1.1548 + }
1.1549 + return TCL_OK;
1.1550 +}
1.1551 +
1.1552 +/*
1.1553 + *---------------------------------------------------------------------------
1.1554 + *
1.1555 + * SetPermissionsAttribute
1.1556 + *
1.1557 + * Sets the file to the given permission.
1.1558 + *
1.1559 + * Results:
1.1560 + * Standard TCL result.
1.1561 + *
1.1562 + * Side effects:
1.1563 + * The permission of the file is changed.
1.1564 + *
1.1565 + *---------------------------------------------------------------------------
1.1566 + */
1.1567 +
1.1568 +static int
1.1569 +SetPermissionsAttribute(interp, objIndex, fileName, attributePtr)
1.1570 + Tcl_Interp *interp; /* The interp we are using for errors. */
1.1571 + int objIndex; /* The index of the attribute. */
1.1572 + Tcl_Obj *fileName; /* The name of the file (UTF-8). */
1.1573 + Tcl_Obj *attributePtr; /* The attribute to set. */
1.1574 +{
1.1575 + long mode;
1.1576 + mode_t newMode;
1.1577 + int result;
1.1578 + CONST char *native;
1.1579 +
1.1580 + /*
1.1581 + * First try if the string is a number
1.1582 + */
1.1583 + if (Tcl_GetLongFromObj(NULL, attributePtr, &mode) == TCL_OK) {
1.1584 + newMode = (mode_t) (mode & 0x00007FFF);
1.1585 + } else {
1.1586 + Tcl_StatBuf buf;
1.1587 + char *modeStringPtr = Tcl_GetString(attributePtr);
1.1588 +
1.1589 + /*
1.1590 + * Try the forms "rwxrwxrwx" and "ugo=rwx"
1.1591 + *
1.1592 + * We get the current mode of the file, in order to allow for
1.1593 + * ug+-=rwx style chmod strings.
1.1594 + */
1.1595 + result = TclpObjStat(fileName, &buf);
1.1596 + if (result != 0) {
1.1597 + Tcl_AppendResult(interp, "could not read \"",
1.1598 + Tcl_GetString(fileName), "\": ",
1.1599 + Tcl_PosixError(interp), (char *) NULL);
1.1600 + return TCL_ERROR;
1.1601 + }
1.1602 + newMode = (mode_t) (buf.st_mode & 0x00007FFF);
1.1603 +
1.1604 + if (GetModeFromPermString(NULL, modeStringPtr, &newMode) != TCL_OK) {
1.1605 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.1606 + "unknown permission string format \"",
1.1607 + modeStringPtr, "\"", (char *) NULL);
1.1608 + return TCL_ERROR;
1.1609 + }
1.1610 + }
1.1611 +
1.1612 + native = Tcl_FSGetNativePath(fileName);
1.1613 + result = chmod(native, newMode); /* INTL: Native. */
1.1614 + if (result != 0) {
1.1615 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.1616 + "could not set permissions for file \"",
1.1617 + Tcl_GetString(fileName), "\": ",
1.1618 + Tcl_PosixError(interp), (char *) NULL);
1.1619 + return TCL_ERROR;
1.1620 + }
1.1621 + return TCL_OK;
1.1622 +}
1.1623 +
1.1624 +/*
1.1625 + *---------------------------------------------------------------------------
1.1626 + *
1.1627 + * TclpObjListVolumes --
1.1628 + *
1.1629 + * Lists the currently mounted volumes, which on UNIX is just /.
1.1630 + *
1.1631 + * Results:
1.1632 + * The list of volumes.
1.1633 + *
1.1634 + * Side effects:
1.1635 + * None.
1.1636 + *
1.1637 + *---------------------------------------------------------------------------
1.1638 + */
1.1639 +
1.1640 +Tcl_Obj*
1.1641 +TclpObjListVolumes(void)
1.1642 +{
1.1643 + Tcl_Obj *resultPtr = Tcl_NewStringObj("/",1);
1.1644 +
1.1645 + Tcl_IncrRefCount(resultPtr);
1.1646 + return resultPtr;
1.1647 +}
1.1648 +
1.1649 +/*
1.1650 + *----------------------------------------------------------------------
1.1651 + *
1.1652 + * GetModeFromPermString --
1.1653 + *
1.1654 + * This procedure is invoked to process the "file permissions"
1.1655 + * Tcl command, to check for a "rwxrwxrwx" or "ugoa+-=rwxst" string.
1.1656 + * See the user documentation for details on what it does.
1.1657 + *
1.1658 + * Results:
1.1659 + * A standard Tcl result.
1.1660 + *
1.1661 + * Side effects:
1.1662 + * See the user documentation.
1.1663 + *
1.1664 + *----------------------------------------------------------------------
1.1665 + */
1.1666 +
1.1667 +static int
1.1668 +GetModeFromPermString(interp, modeStringPtr, modePtr)
1.1669 + Tcl_Interp *interp; /* The interp we are using for errors. */
1.1670 + char *modeStringPtr; /* Permissions string */
1.1671 + mode_t *modePtr; /* pointer to the mode value */
1.1672 +{
1.1673 + mode_t newMode;
1.1674 + mode_t oldMode; /* Storage for the value of the old mode
1.1675 + * (that is passed in), to allow for the
1.1676 + * chmod style manipulation */
1.1677 + int i,n, who, op, what, op_found, who_found;
1.1678 +
1.1679 + /*
1.1680 + * We start off checking for an "rwxrwxrwx" style permissions string
1.1681 + */
1.1682 + if (strlen(modeStringPtr) != 9) {
1.1683 + goto chmodStyleCheck;
1.1684 + }
1.1685 +
1.1686 + newMode = 0;
1.1687 + for (i = 0; i < 9; i++) {
1.1688 + switch (*(modeStringPtr+i)) {
1.1689 + case 'r':
1.1690 + if ((i%3) != 0) {
1.1691 + goto chmodStyleCheck;
1.1692 + }
1.1693 + newMode |= (1<<(8-i));
1.1694 + break;
1.1695 + case 'w':
1.1696 + if ((i%3) != 1) {
1.1697 + goto chmodStyleCheck;
1.1698 + }
1.1699 + newMode |= (1<<(8-i));
1.1700 + break;
1.1701 + case 'x':
1.1702 + if ((i%3) != 2) {
1.1703 + goto chmodStyleCheck;
1.1704 + }
1.1705 + newMode |= (1<<(8-i));
1.1706 + break;
1.1707 + case 's':
1.1708 + if (((i%3) != 2) || (i > 5)) {
1.1709 + goto chmodStyleCheck;
1.1710 + }
1.1711 + newMode |= (1<<(8-i));
1.1712 + newMode |= (1<<(11-(i/3)));
1.1713 + break;
1.1714 + case 'S':
1.1715 + if (((i%3) != 2) || (i > 5)) {
1.1716 + goto chmodStyleCheck;
1.1717 + }
1.1718 + newMode |= (1<<(11-(i/3)));
1.1719 + break;
1.1720 + case 't':
1.1721 + if (i != 8) {
1.1722 + goto chmodStyleCheck;
1.1723 + }
1.1724 + newMode |= (1<<(8-i));
1.1725 + newMode |= (1<<9);
1.1726 + break;
1.1727 + case 'T':
1.1728 + if (i != 8) {
1.1729 + goto chmodStyleCheck;
1.1730 + }
1.1731 + newMode |= (1<<9);
1.1732 + break;
1.1733 + case '-':
1.1734 + break;
1.1735 + default:
1.1736 + /*
1.1737 + * Oops, not what we thought it was, so go on
1.1738 + */
1.1739 + goto chmodStyleCheck;
1.1740 + }
1.1741 + }
1.1742 + *modePtr = newMode;
1.1743 + return TCL_OK;
1.1744 +
1.1745 + chmodStyleCheck:
1.1746 + /*
1.1747 + * We now check for an "ugoa+-=rwxst" style permissions string
1.1748 + */
1.1749 +
1.1750 + for (n = 0 ; *(modeStringPtr+n) != '\0' ; n = n + i) {
1.1751 + oldMode = *modePtr;
1.1752 + who = op = what = op_found = who_found = 0;
1.1753 + for (i = 0 ; *(modeStringPtr+n+i) != '\0' ; i++ ) {
1.1754 + if (!who_found) {
1.1755 + /* who */
1.1756 + switch (*(modeStringPtr+n+i)) {
1.1757 + case 'u' :
1.1758 + who |= 0x9c0;
1.1759 + continue;
1.1760 + case 'g' :
1.1761 + who |= 0x438;
1.1762 + continue;
1.1763 + case 'o' :
1.1764 + who |= 0x207;
1.1765 + continue;
1.1766 + case 'a' :
1.1767 + who |= 0xfff;
1.1768 + continue;
1.1769 + }
1.1770 + }
1.1771 + who_found = 1;
1.1772 + if (who == 0) {
1.1773 + who = 0xfff;
1.1774 + }
1.1775 + if (!op_found) {
1.1776 + /* op */
1.1777 + switch (*(modeStringPtr+n+i)) {
1.1778 + case '+' :
1.1779 + op = 1;
1.1780 + op_found = 1;
1.1781 + continue;
1.1782 + case '-' :
1.1783 + op = 2;
1.1784 + op_found = 1;
1.1785 + continue;
1.1786 + case '=' :
1.1787 + op = 3;
1.1788 + op_found = 1;
1.1789 + continue;
1.1790 + default :
1.1791 + return TCL_ERROR;
1.1792 + }
1.1793 + }
1.1794 + /* what */
1.1795 + switch (*(modeStringPtr+n+i)) {
1.1796 + case 'r' :
1.1797 + what |= 0x124;
1.1798 + continue;
1.1799 + case 'w' :
1.1800 + what |= 0x92;
1.1801 + continue;
1.1802 + case 'x' :
1.1803 + what |= 0x49;
1.1804 + continue;
1.1805 + case 's' :
1.1806 + what |= 0xc00;
1.1807 + continue;
1.1808 + case 't' :
1.1809 + what |= 0x200;
1.1810 + continue;
1.1811 + case ',' :
1.1812 + break;
1.1813 + default :
1.1814 + return TCL_ERROR;
1.1815 + }
1.1816 + if (*(modeStringPtr+n+i) == ',') {
1.1817 + i++;
1.1818 + break;
1.1819 + }
1.1820 + }
1.1821 + switch (op) {
1.1822 + case 1 :
1.1823 + *modePtr = oldMode | (who & what);
1.1824 + continue;
1.1825 + case 2 :
1.1826 + *modePtr = oldMode & ~(who & what);
1.1827 + continue;
1.1828 + case 3 :
1.1829 + *modePtr = (oldMode & ~who) | (who & what);
1.1830 + continue;
1.1831 + }
1.1832 + }
1.1833 + return TCL_OK;
1.1834 +}
1.1835 +
1.1836 +/*
1.1837 + *---------------------------------------------------------------------------
1.1838 + *
1.1839 + * TclpObjNormalizePath --
1.1840 + *
1.1841 + * This function scans through a path specification and replaces
1.1842 + * it, in place, with a normalized version. A normalized version
1.1843 + * is one in which all symlinks in the path are replaced with
1.1844 + * their expanded form (except a symlink at the very end of the
1.1845 + * path).
1.1846 + *
1.1847 + * Results:
1.1848 + * The new 'nextCheckpoint' value, giving as far as we could
1.1849 + * understand in the path.
1.1850 + *
1.1851 + * Side effects:
1.1852 + * The pathPtr string, is modified.
1.1853 + *
1.1854 + *---------------------------------------------------------------------------
1.1855 + */
1.1856 +int
1.1857 +TclpObjNormalizePath(interp, pathPtr, nextCheckpoint)
1.1858 + Tcl_Interp *interp;
1.1859 + Tcl_Obj *pathPtr;
1.1860 + int nextCheckpoint;
1.1861 +{
1.1862 + char *currentPathEndPosition;
1.1863 + int pathLen;
1.1864 + char cur;
1.1865 + char *path = Tcl_GetStringFromObj(pathPtr, &pathLen);
1.1866 +#ifndef NO_REALPATH
1.1867 + char normPath[MAXPATHLEN];
1.1868 + Tcl_DString ds;
1.1869 + CONST char *nativePath;
1.1870 +#endif
1.1871 + /*
1.1872 + * We add '1' here because if nextCheckpoint is zero we know
1.1873 + * that '/' exists, and if it isn't zero, it must point at
1.1874 + * a directory separator which we also know exists.
1.1875 + */
1.1876 + currentPathEndPosition = path + nextCheckpoint;
1.1877 + if (*currentPathEndPosition == '/') {
1.1878 + currentPathEndPosition++;
1.1879 + }
1.1880 +
1.1881 +#ifndef NO_REALPATH
1.1882 + /* For speed, try to get the entire path in one go */
1.1883 + if (nextCheckpoint == 0 && haveRealpath) {
1.1884 + char *lastDir = strrchr(currentPathEndPosition, '/');
1.1885 + if (lastDir != NULL) {
1.1886 + nativePath = Tcl_UtfToExternalDString(NULL, path,
1.1887 + lastDir - path, &ds);
1.1888 +
1.1889 + if (Realpath(nativePath, normPath) != NULL) {
1.1890 +
1.1891 + if (*nativePath != '/' && *normPath == '/') {
1.1892 + /*
1.1893 + * realpath has transformed a relative path into an
1.1894 + * absolute path, we do not know how to handle this.
1.1895 + */
1.1896 + } else {
1.1897 + nextCheckpoint = lastDir - path;
1.1898 + goto wholeStringOk;
1.1899 + }
1.1900 + }
1.1901 + Tcl_DStringFree(&ds);
1.1902 + }
1.1903 + }
1.1904 + /* Else do it the slow way */
1.1905 +#endif
1.1906 +
1.1907 + while (1) {
1.1908 + cur = *currentPathEndPosition;
1.1909 + if ((cur == '/') && (path != currentPathEndPosition)) {
1.1910 + /* Reached directory separator */
1.1911 + Tcl_DString ds;
1.1912 + CONST char *nativePath;
1.1913 + int accessOk;
1.1914 +
1.1915 + nativePath = Tcl_UtfToExternalDString(NULL, path,
1.1916 + currentPathEndPosition - path, &ds);
1.1917 + accessOk = access(nativePath, F_OK);
1.1918 + Tcl_DStringFree(&ds);
1.1919 + if (accessOk != 0) {
1.1920 + /* File doesn't exist */
1.1921 + break;
1.1922 + }
1.1923 + /* Update the acceptable point */
1.1924 + nextCheckpoint = currentPathEndPosition - path;
1.1925 + } else if (cur == 0) {
1.1926 + /* Reached end of string */
1.1927 + break;
1.1928 + }
1.1929 + currentPathEndPosition++;
1.1930 + }
1.1931 + /*
1.1932 + * We should really now convert this to a canonical path. We do
1.1933 + * that with 'realpath' if we have it available. Otherwise we could
1.1934 + * step through every single path component, checking whether it is a
1.1935 + * symlink, but that would be a lot of work, and most modern OSes
1.1936 + * have 'realpath'.
1.1937 + */
1.1938 +#ifndef NO_REALPATH
1.1939 + if (haveRealpath) {
1.1940 + /*
1.1941 + * If we only had '/foo' or '/' then we never increment nextCheckpoint
1.1942 + * and we don't need or want to go through 'Realpath'. Also, on some
1.1943 + * platforms, passing an empty string to 'Realpath' will give us the
1.1944 + * normalized pwd, which is not what we want at all!
1.1945 + */
1.1946 + if (nextCheckpoint == 0) return 0;
1.1947 +
1.1948 + nativePath = Tcl_UtfToExternalDString(NULL, path, nextCheckpoint, &ds);
1.1949 +
1.1950 + if (Realpath(nativePath, normPath) != NULL) {
1.1951 + int newNormLen;
1.1952 + wholeStringOk:
1.1953 + newNormLen = strlen(normPath);
1.1954 + if ((newNormLen == Tcl_DStringLength(&ds))
1.1955 + && (strcmp(normPath, nativePath) == 0)) {
1.1956 + /* String is unchanged */
1.1957 + Tcl_DStringFree(&ds);
1.1958 + if (path[nextCheckpoint] != '\0') {
1.1959 + nextCheckpoint++;
1.1960 + }
1.1961 + return nextCheckpoint;
1.1962 + }
1.1963 +
1.1964 + /*
1.1965 + * Free up the native path and put in its place the
1.1966 + * converted, normalized path.
1.1967 + */
1.1968 + Tcl_DStringFree(&ds);
1.1969 + Tcl_ExternalToUtfDString(NULL, normPath, (int) newNormLen, &ds);
1.1970 +
1.1971 + if (path[nextCheckpoint] != '\0') {
1.1972 + /* not at end, append remaining path */
1.1973 + int normLen = Tcl_DStringLength(&ds);
1.1974 + Tcl_DStringAppend(&ds, path + nextCheckpoint,
1.1975 + pathLen - nextCheckpoint);
1.1976 + /*
1.1977 + * We recognise up to and including the directory
1.1978 + * separator.
1.1979 + */
1.1980 + nextCheckpoint = normLen + 1;
1.1981 + } else {
1.1982 + /* We recognise the whole string */
1.1983 + nextCheckpoint = Tcl_DStringLength(&ds);
1.1984 + }
1.1985 + /*
1.1986 + * Overwrite with the normalized path.
1.1987 + */
1.1988 + Tcl_SetStringObj(pathPtr, Tcl_DStringValue(&ds),
1.1989 + Tcl_DStringLength(&ds));
1.1990 + }
1.1991 + Tcl_DStringFree(&ds);
1.1992 + }
1.1993 +#endif /* !NO_REALPATH */
1.1994 +
1.1995 + return nextCheckpoint;
1.1996 +}