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