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 */ 49 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 62 63/* 64 * The following constants specify the type of callback when 65 * TraverseUnixTree() calls the traverseProc() 66 */ 67 68#define DOTREE_PRED 1 /* pre-order directory */ 69#define DOTREE_POSTD 2 /* post-order directory */ 70#define DOTREE_F 3 /* regular file */ 71 72/* 73 * Callbacks for file attributes code. 74 */ 75 76static int GetGroupAttribute _ANSI_ARGS_((Tcl_Interp *interp, 77 int objIndex, Tcl_Obj *fileName, 78 Tcl_Obj **attributePtrPtr)); 79static int GetOwnerAttribute _ANSI_ARGS_((Tcl_Interp *interp, 80 int objIndex, Tcl_Obj *fileName, 81 Tcl_Obj **attributePtrPtr)); 82static int GetPermissionsAttribute _ANSI_ARGS_(( 83 Tcl_Interp *interp, int objIndex, 84 Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr)); 85static int SetGroupAttribute _ANSI_ARGS_((Tcl_Interp *interp, 86 int objIndex, Tcl_Obj *fileName, 87 Tcl_Obj *attributePtr)); 88static int SetOwnerAttribute _ANSI_ARGS_((Tcl_Interp *interp, 89 int objIndex, Tcl_Obj *fileName, 90 Tcl_Obj *attributePtr)); 91static int SetPermissionsAttribute _ANSI_ARGS_(( 92 Tcl_Interp *interp, int objIndex, 93 Tcl_Obj *fileName, Tcl_Obj *attributePtr)); 94static int GetModeFromPermString _ANSI_ARGS_(( 95 Tcl_Interp *interp, char *modeStringPtr, 96 mode_t *modePtr)); 97 98/* 99 * Prototype for the TraverseUnixTree callback function. 100 */ 101 102typedef int (TraversalProc) _ANSI_ARGS_((Tcl_DString *srcPtr, 103 Tcl_DString *dstPtr, CONST Tcl_StatBuf *statBufPtr, int type, 104 Tcl_DString *errorPtr)); 105 106/* 107 * Constants and variables necessary for file attributes subcommand. 108 */ 109 110enum { 111 UNIX_GROUP_ATTRIBUTE, 112 UNIX_OWNER_ATTRIBUTE, 113 UNIX_PERMISSIONS_ATTRIBUTE 114}; 115 116CONST char *tclpFileAttrStrings[] = { 117 "-group", 118 "-owner", 119 "-permissions", 120 (char *) NULL 121}; 122 123CONST TclFileAttrProcs tclpFileAttrProcs[] = { 124 {GetGroupAttribute, SetGroupAttribute}, 125 {GetOwnerAttribute, SetOwnerAttribute}, 126 {GetPermissionsAttribute, SetPermissionsAttribute} 127}; 128 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 */ 141 142#define MAX_READDIR_UNLINK_THRESHOLD 130 143 144/* 145 * Declarations for local procedures defined in this file: 146 */ 147 148static int CopyFile _ANSI_ARGS_((CONST char *src, 149 CONST char *dst, CONST Tcl_StatBuf *statBufPtr)); 150static int CopyFileAtts _ANSI_ARGS_((CONST char *src, 151 CONST char *dst, CONST Tcl_StatBuf *statBufPtr)); 152static int DoCopyFile _ANSI_ARGS_((CONST char *srcPtr, 153 CONST char *dstPtr, CONST Tcl_StatBuf *statBufPtr)); 154static int DoCreateDirectory _ANSI_ARGS_((CONST char *pathPtr)); 155static int DoRemoveDirectory _ANSI_ARGS_((Tcl_DString *pathPtr, 156 int recursive, Tcl_DString *errorPtr)); 157static int DoRenameFile _ANSI_ARGS_((CONST char *src, 158 CONST char *dst)); 159static int TraversalCopy _ANSI_ARGS_((Tcl_DString *srcPtr, 160 Tcl_DString *dstPtr, CONST Tcl_StatBuf *statBufPtr, 161 int type, Tcl_DString *errorPtr)); 162static int TraversalDelete _ANSI_ARGS_((Tcl_DString *srcPtr, 163 Tcl_DString *dstPtr, CONST Tcl_StatBuf *statBufPtr, 164 int type, Tcl_DString *errorPtr)); 165static int TraverseUnixTree _ANSI_ARGS_(( 166 TraversalProc *traversalProc, 167 Tcl_DString *sourcePtr, Tcl_DString *destPtr, 168 Tcl_DString *errorPtr, int doRewind)); 169 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 */ 177static char * Realpath _ANSI_ARGS_((CONST char *path, 178 char *resolved)); 179 180char * 181Realpath(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 191 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 */ 201extern long tclMacOSXDarwinRelease; 202#define haveRealpath (tclMacOSXDarwinRelease >= 7) 203#else 204#define haveRealpath 1 205#endif 206#endif /* NO_REALPATH */ 207 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 */ 220extern long tclMacOSXDarwinRelease; 221#define noFtsStat (tclMacOSXDarwinRelease < 9) 222#else 223#define noFtsStat 0 224#endif 225#endif /* HAVE_FTS */ 226 227 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 */ 262 263int 264TclpObjRenameFile(srcPathPtr, destPathPtr) 265 Tcl_Obj *srcPathPtr; 266 Tcl_Obj *destPathPtr; 267{ 268 return DoRenameFile(Tcl_FSGetNativePath(srcPathPtr), 269 Tcl_FSGetNativePath(destPathPtr)); 270} 271 272static int 273DoRenameFile(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 } 285 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 */ 303 304 if (errno == EINVAL && haveRealpath) { 305 char srcPath[MAXPATHLEN], dstPath[MAXPATHLEN]; 306 DIR *dirPtr; 307 Tcl_DirEntry *dirEntPtr; 308 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 */ 332 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 } 341 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 */ 348 349 return TCL_ERROR; 350} 351 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 */ 378 379int 380TclpObjCopyFile(srcPathPtr, destPathPtr) 381 Tcl_Obj *srcPathPtr; 382 Tcl_Obj *destPathPtr; 383{ 384 CONST char *src = Tcl_FSGetNativePath(srcPathPtr); 385 Tcl_StatBuf srcStatBuf; 386 387 if (TclOSlstat(src, &srcStatBuf) != 0) { /* INTL: Native. */ 388 return TCL_ERROR; 389 } 390 391 return DoCopyFile(src, Tcl_FSGetNativePath(destPathPtr), &srcStatBuf); 392} 393 394static int 395DoCopyFile(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; 402 403 if (S_ISDIR(statBufPtr->st_mode)) { 404 errno = EISDIR; 405 return TCL_ERROR; 406 } 407 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 } 424 425 switch ((int) (statBufPtr->st_mode & S_IFMT)) { 426#ifndef DJGPP 427 case S_IFLNK: { 428 char link[MAXPATHLEN]; 429 int length; 430 431 length = readlink(src, link, sizeof(link)); /* INTL: Native. */ 432 if (length == -1) { 433 return TCL_ERROR; 434 } 435 link[length] = '\0'; 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} 468 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 */ 485 486static int 487CopyFile(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; 499 500 if ((srcFd = TclOSopen(src, O_RDONLY, 0)) < 0) { /* INTL: Native. */ 501 return TCL_ERROR; 502 } 503 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 } 510 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 527 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 */ 534 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 } 549 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 */ 562 563 unlink(dst); /* INTL: Native. */ 564 return TCL_ERROR; 565 } 566 return TCL_OK; 567} 568 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 */ 590 591int 592TclpObjDeleteFile(pathPtr) 593 Tcl_Obj *pathPtr; 594{ 595 return TclpDeleteFile(Tcl_FSGetNativePath(pathPtr)); 596} 597 598int 599TclpDeleteFile(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} 607 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 */ 633 634int 635TclpObjCreateDirectory(pathPtr) 636 Tcl_Obj *pathPtr; 637{ 638 return DoCreateDirectory(Tcl_FSGetNativePath(pathPtr)); 639} 640 641static int 642DoCreateDirectory(path) 643 CONST char *path; /* Pathname of directory to create (native). */ 644{ 645 mode_t mode; 646 647 mode = umask(0); 648 umask(mode); 649 650 /* 651 * umask return value is actually the inverse of the permissions. 652 */ 653 654 mode = (0777 & ~mode) | S_IRUSR | S_IWUSR | S_IXUSR; 655 656 if (mkdir(path, mode) != 0) { /* INTL: Native. */ 657 return TCL_ERROR; 658 } 659 return TCL_OK; 660} 661 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 */ 687 688int 689TclpObjCopyDirectory(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 } 713 714 ret = TraverseUnixTree(TraversalCopy, &srcString, &dstString, &ds, 0); 715 716 Tcl_DStringFree(&srcString); 717 Tcl_DStringFree(&dstString); 718 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} 726 727 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 754int 755TclpObjRemoveDirectory(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); 764 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); 773 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} 781 782static int 783DoRemoveDirectory(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; 803 804 if (TclOSstat(path, &statBuf) == 0) { 805 oldPerm = (mode_t) (statBuf.st_mode & 0x00007FFF); 806 } 807 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 } 818 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 */ 831 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} 842 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 */ 864 865static int 866TraverseUnixTree(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 896 897 errfile = NULL; 898 result = TCL_OK; 899 targetLen = 0; /* lint. */ 900 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 */ 910 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 */ 920 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 } 930 931 Tcl_DStringAppend(sourcePtr, "/", 1); 932 sourceLen = Tcl_DStringLength(sourcePtr); 933 934 if (targetPtr != NULL) { 935 Tcl_DStringAppend(targetPtr, "/", 1); 936 targetLen = Tcl_DStringLength(targetPtr); 937 } 938 939 while ((dirEntPtr = TclOSreaddir(dirPtr)) != NULL) { /* INTL: Native. */ 940 if ((dirEntPtr->d_name[0] == '.') 941 && ((dirEntPtr->d_name[1] == '\0') 942 || (strcmp(dirEntPtr->d_name, "..") == 0))) { 943 continue; 944 } 945 946 /* 947 * Append name after slash, and recurse on the file. 948 */ 949 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 } 961 962 /* 963 * Remove name after slash. 964 */ 965 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); 981 982 /* 983 * Strip off the trailing slash we added 984 */ 985 986 Tcl_DStringSetLength(sourcePtr, sourceLen - 1); 987 if (targetPtr != NULL) { 988 Tcl_DStringSetLength(targetPtr, targetLen - 1); 989 } 990 991 if (result == TCL_OK) { 992 /* 993 * Call traverseProc() on a directory after visiting all the 994 * files in that directory. 995 */ 996 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 } 1008 1009 sourceLen = Tcl_DStringLength(sourcePtr); 1010 if (targetPtr != NULL) { 1011 targetLen = Tcl_DStringLength(targetPtr); 1012 } 1013 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; 1020 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 */ 1062 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 */ 1075 1076 return result; 1077} 1078 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 */ 1096 1097static int 1098TraversalCopy(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; 1115 1116 case DOTREE_PRED: 1117 if (DoCreateDirectory(Tcl_DStringValue(dstPtr)) == TCL_OK) { 1118 return TCL_OK; 1119 } 1120 break; 1121 1122 case DOTREE_POSTD: 1123 if (CopyFileAtts(Tcl_DStringValue(srcPtr), 1124 Tcl_DStringValue(dstPtr), statBufPtr) == TCL_OK) { 1125 return TCL_OK; 1126 } 1127 break; 1128 1129 } 1130 1131 /* 1132 * There shouldn't be a problem with src, because we already checked it 1133 * to get here. 1134 */ 1135 1136 if (errorPtr != NULL) { 1137 Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(dstPtr), 1138 Tcl_DStringLength(dstPtr), errorPtr); 1139 } 1140 return TCL_ERROR; 1141} 1142 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 */ 1161 1162static int 1163TraversalDelete(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} 1196 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 */ 1215 1216static int 1217CopyFileAtts(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); 1228 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 } 1244 1245 tval.actime = statBufPtr->st_atime; 1246 tval.modtime = statBufPtr->st_mtime; 1247 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} 1259 1260 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 */ 1277 1278static int 1279GetGroupAttribute(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; 1288 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 } 1297 1298 groupPtr = TclpGetGrGid(statBuf.st_gid); 1299 1300 if (result == -1 || groupPtr == NULL) { 1301 *attributePtrPtr = Tcl_NewIntObj((int) statBuf.st_gid); 1302 } else { 1303 Tcl_DString ds; 1304 CONST char *utf; 1305 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} 1313 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 */ 1330 1331static int 1332GetOwnerAttribute(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; 1341 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 } 1350 1351 pwPtr = TclpGetPwUid(statBuf.st_uid); 1352 1353 if (result == -1 || pwPtr == NULL) { 1354 *attributePtrPtr = Tcl_NewIntObj((int) statBuf.st_uid); 1355 } else { 1356 Tcl_DString ds; 1357 CONST char *utf; 1358 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} 1366 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 */ 1383 1384static int 1385GetPermissionsAttribute(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; 1394 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 } 1403 1404 sprintf(returnString, "%0#5lo", (long) (statBuf.st_mode & 0x00007FFF)); 1405 1406 *attributePtrPtr = Tcl_NewStringObj(returnString, -1); 1407 1408 return TCL_OK; 1409} 1410 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 */ 1426 1427static int 1428SetGroupAttribute(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; 1437 1438 if (Tcl_GetLongFromObj(NULL, attributePtr, &gid) != TCL_OK) { 1439 Tcl_DString ds; 1440 struct group *groupPtr; 1441 CONST char *string; 1442 int length; 1443 1444 string = Tcl_GetStringFromObj(attributePtr, &length); 1445 native = Tcl_UtfToExternalDString(NULL, string, length, &ds); 1446 groupPtr = TclpGetGrNam(native); /* INTL: Native. */ 1447 Tcl_DStringFree(&ds); 1448 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 } 1459 1460 native = Tcl_FSGetNativePath(fileName); 1461 result = chown(native, (uid_t) -1, (gid_t) gid); /* INTL: Native. */ 1462 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} 1472 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 */ 1488 1489static int 1490SetOwnerAttribute(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; 1499 1500 if (Tcl_GetLongFromObj(NULL, attributePtr, &uid) != TCL_OK) { 1501 Tcl_DString ds; 1502 struct passwd *pwPtr; 1503 CONST char *string; 1504 int length; 1505 1506 string = Tcl_GetStringFromObj(attributePtr, &length); 1507 native = Tcl_UtfToExternalDString(NULL, string, length, &ds); 1508 pwPtr = TclpGetPwNam(native); /* INTL: Native. */ 1509 Tcl_DStringFree(&ds); 1510 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 } 1521 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} 1534 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 */ 1550 1551static int 1552SetPermissionsAttribute(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; 1562 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); 1571 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); 1586 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 } 1594 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} 1606 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 */ 1622 1623Tcl_Obj* 1624TclpObjListVolumes(void) 1625{ 1626 Tcl_Obj *resultPtr = Tcl_NewStringObj("/",1); 1627 1628 Tcl_IncrRefCount(resultPtr); 1629 return resultPtr; 1630} 1631 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 */ 1649 1650static int 1651GetModeFromPermString(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; 1661 1662 /* 1663 * We start off checking for an "rwxrwxrwx" style permissions string 1664 */ 1665 if (strlen(modeStringPtr) != 9) { 1666 goto chmodStyleCheck; 1667 } 1668 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; 1727 1728 chmodStyleCheck: 1729 /* 1730 * We now check for an "ugoa+-=rwxst" style permissions string 1731 */ 1732 1733 for (n = 0 ; *(modeStringPtr+n) != '\0' ; n = n + i) { 1734 oldMode = *modePtr; 1735 who = op = what = op_found = who_found = 0; 1736 for (i = 0 ; *(modeStringPtr+n+i) != '\0' ; 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} 1818 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 */ 1839int 1840TclpObjNormalizePath(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 } 1863 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; 1895 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; 1928 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] != '\0') { 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] != '\0') { 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 */ 1974 1975 return nextCheckpoint; 1976} 1977