1/* 2 * tclFCmd.c 3 * 4 * This file implements the generic portion of file manipulation 5 * subcommands of the "file" command. 6 * 7 * Copyright (c) 1996-1998 Sun Microsystems, Inc. 8 * 9 * See the file "license.terms" for information on usage and redistribution of 10 * this file, and for a DISCLAIMER OF ALL WARRANTIES. 11 * 12 * RCS: @(#) $Id: tclFCmd.c,v 1.43.2.1 2008/07/21 14:56:10 patthoyts Exp $ 13 */ 14 15#include "tclInt.h" 16 17/* 18 * Declarations for local functions defined in this file: 19 */ 20 21static int CopyRenameOneFile(Tcl_Interp *interp, 22 Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr, 23 int copyFlag, int force); 24static Tcl_Obj * FileBasename(Tcl_Interp *interp, Tcl_Obj *pathPtr); 25static int FileCopyRename(Tcl_Interp *interp, 26 int objc, Tcl_Obj *CONST objv[], int copyFlag); 27static int FileForceOption(Tcl_Interp *interp, 28 int objc, Tcl_Obj *CONST objv[], int *forcePtr); 29 30/* 31 *--------------------------------------------------------------------------- 32 * 33 * TclFileRenameCmd 34 * 35 * This function implements the "rename" subcommand of the "file" 36 * command. Filename arguments need to be translated to native format 37 * before being passed to platform-specific code that implements rename 38 * functionality. 39 * 40 * Results: 41 * A standard Tcl result. 42 * 43 * Side effects: 44 * See the user documentation. 45 * 46 *--------------------------------------------------------------------------- 47 */ 48 49int 50TclFileRenameCmd( 51 Tcl_Interp *interp, /* Interp for error reporting or recursive 52 * calls in the case of a tricky rename. */ 53 int objc, /* Number of arguments. */ 54 Tcl_Obj *CONST objv[]) /* Argument strings passed to Tcl_FileCmd. */ 55{ 56 return FileCopyRename(interp, objc, objv, 0); 57} 58 59/* 60 *--------------------------------------------------------------------------- 61 * 62 * TclFileCopyCmd 63 * 64 * This function implements the "copy" subcommand of the "file" command. 65 * Filename arguments need to be translated to native format before being 66 * passed to platform-specific code that implements copy functionality. 67 * 68 * Results: 69 * A standard Tcl result. 70 * 71 * Side effects: 72 * See the user documentation. 73 * 74 *--------------------------------------------------------------------------- 75 */ 76 77int 78TclFileCopyCmd( 79 Tcl_Interp *interp, /* Used for error reporting or recursive calls 80 * in the case of a tricky copy. */ 81 int objc, /* Number of arguments. */ 82 Tcl_Obj *CONST objv[]) /* Argument strings passed to Tcl_FileCmd. */ 83{ 84 return FileCopyRename(interp, objc, objv, 1); 85} 86 87/* 88 *--------------------------------------------------------------------------- 89 * 90 * FileCopyRename -- 91 * 92 * Performs the work of TclFileRenameCmd and TclFileCopyCmd. See 93 * comments for those functions. 94 * 95 * Results: 96 * See above. 97 * 98 * Side effects: 99 * See above. 100 * 101 *--------------------------------------------------------------------------- 102 */ 103 104static int 105FileCopyRename( 106 Tcl_Interp *interp, /* Used for error reporting. */ 107 int objc, /* Number of arguments. */ 108 Tcl_Obj *CONST objv[], /* Argument strings passed to Tcl_FileCmd. */ 109 int copyFlag) /* If non-zero, copy source(s). Otherwise, 110 * rename them. */ 111{ 112 int i, result, force; 113 Tcl_StatBuf statBuf; 114 Tcl_Obj *target; 115 116 i = FileForceOption(interp, objc - 2, objv + 2, &force); 117 if (i < 0) { 118 return TCL_ERROR; 119 } 120 i += 2; 121 if ((objc - i) < 2) { 122 Tcl_AppendResult(interp, "wrong # args: should be \"", 123 TclGetString(objv[0]), " ", TclGetString(objv[1]), 124 " ?options? source ?source ...? target\"", NULL); 125 return TCL_ERROR; 126 } 127 128 /* 129 * If target doesn't exist or isn't a directory, try the copy/rename. 130 * More than 2 arguments is only valid if the target is an existing 131 * directory. 132 */ 133 134 target = objv[objc - 1]; 135 if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) { 136 return TCL_ERROR; 137 } 138 139 result = TCL_OK; 140 141 /* 142 * Call Tcl_FSStat() so that if target is a symlink that points to a 143 * directory we will put the sources in that directory instead of 144 * overwriting the symlink. 145 */ 146 147 if ((Tcl_FSStat(target, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) { 148 if ((objc - i) > 2) { 149 errno = ENOTDIR; 150 Tcl_PosixError(interp); 151 Tcl_AppendResult(interp, "error ", 152 (copyFlag ? "copying" : "renaming"), ": target \"", 153 TclGetString(target), "\" is not a directory", NULL); 154 result = TCL_ERROR; 155 } else { 156 /* 157 * Even though already have target == translated(objv[i+1]), pass 158 * the original argument down, so if there's an error, the error 159 * message will reflect the original arguments. 160 */ 161 162 result = CopyRenameOneFile(interp, objv[i], objv[i + 1], copyFlag, 163 force); 164 } 165 return result; 166 } 167 168 /* 169 * Move each source file into target directory. Extract the basename from 170 * each source, and append it to the end of the target path. 171 */ 172 173 for ( ; i<objc-1 ; i++) { 174 Tcl_Obj *jargv[2]; 175 Tcl_Obj *source, *newFileName; 176 Tcl_Obj *temp; 177 178 source = FileBasename(interp, objv[i]); 179 if (source == NULL) { 180 result = TCL_ERROR; 181 break; 182 } 183 jargv[0] = objv[objc - 1]; 184 jargv[1] = source; 185 temp = Tcl_NewListObj(2, jargv); 186 newFileName = Tcl_FSJoinPath(temp, -1); 187 Tcl_IncrRefCount(newFileName); 188 result = CopyRenameOneFile(interp, objv[i], newFileName, copyFlag, 189 force); 190 Tcl_DecrRefCount(newFileName); 191 Tcl_DecrRefCount(temp); 192 Tcl_DecrRefCount(source); 193 194 if (result == TCL_ERROR) { 195 break; 196 } 197 } 198 return result; 199} 200 201/* 202 *--------------------------------------------------------------------------- 203 * 204 * TclFileMakeDirsCmd 205 * 206 * This function implements the "mkdir" subcommand of the "file" command. 207 * Filename arguments need to be translated to native format before being 208 * passed to platform-specific code that implements mkdir functionality. 209 * 210 * Results: 211 * A standard Tcl result. 212 * 213 * Side effects: 214 * See the user documentation. 215 * 216 *---------------------------------------------------------------------- 217 */ 218 219int 220TclFileMakeDirsCmd( 221 Tcl_Interp *interp, /* Used for error reporting. */ 222 int objc, /* Number of arguments */ 223 Tcl_Obj *CONST objv[]) /* Argument strings passed to Tcl_FileCmd. */ 224{ 225 Tcl_Obj *errfile; 226 int result, i, j, pobjc; 227 Tcl_Obj *split = NULL; 228 Tcl_Obj *target = NULL; 229 Tcl_StatBuf statBuf; 230 231 errfile = NULL; 232 233 result = TCL_OK; 234 for (i = 2; i < objc; i++) { 235 if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) { 236 result = TCL_ERROR; 237 break; 238 } 239 240 split = Tcl_FSSplitPath(objv[i],&pobjc); 241 Tcl_IncrRefCount(split); 242 if (pobjc == 0) { 243 errno = ENOENT; 244 errfile = objv[i]; 245 break; 246 } 247 for (j = 0; j < pobjc; j++) { 248 target = Tcl_FSJoinPath(split, j + 1); 249 Tcl_IncrRefCount(target); 250 251 /* 252 * Call Tcl_FSStat() so that if target is a symlink that points to 253 * a directory we will create subdirectories in that directory. 254 */ 255 256 if (Tcl_FSStat(target, &statBuf) == 0) { 257 if (!S_ISDIR(statBuf.st_mode)) { 258 errno = EEXIST; 259 errfile = target; 260 goto done; 261 } 262 } else if (errno != ENOENT) { 263 /* 264 * If Tcl_FSStat() failed and the error is anything other than 265 * non-existence of the target, throw the error. 266 */ 267 268 errfile = target; 269 goto done; 270 } else if (Tcl_FSCreateDirectory(target) != TCL_OK) { 271 /* 272 * Create might have failed because of being in a race 273 * condition with another process trying to create the same 274 * subdirectory. 275 */ 276 277 if (errno == EEXIST) { 278 if ((Tcl_FSStat(target, &statBuf) == 0) 279 && S_ISDIR(statBuf.st_mode)) { 280 /* 281 * It is a directory that wasn't there before, so keep 282 * going without error. 283 */ 284 285 Tcl_ResetResult(interp); 286 } else { 287 errfile = target; 288 goto done; 289 } 290 } else { 291 errfile = target; 292 goto done; 293 } 294 } 295 296 /* 297 * Forget about this sub-path. 298 */ 299 300 Tcl_DecrRefCount(target); 301 target = NULL; 302 } 303 Tcl_DecrRefCount(split); 304 split = NULL; 305 } 306 307 done: 308 if (errfile != NULL) { 309 Tcl_AppendResult(interp, "can't create directory \"", 310 TclGetString(errfile), "\": ", Tcl_PosixError(interp), NULL); 311 result = TCL_ERROR; 312 } 313 if (split != NULL) { 314 Tcl_DecrRefCount(split); 315 } 316 if (target != NULL) { 317 Tcl_DecrRefCount(target); 318 } 319 return result; 320} 321 322/* 323 *---------------------------------------------------------------------- 324 * 325 * TclFileDeleteCmd 326 * 327 * This function implements the "delete" subcommand of the "file" 328 * command. 329 * 330 * Results: 331 * A standard Tcl result. 332 * 333 * Side effects: 334 * See the user documentation. 335 * 336 *---------------------------------------------------------------------- 337 */ 338 339int 340TclFileDeleteCmd( 341 Tcl_Interp *interp, /* Used for error reporting */ 342 int objc, /* Number of arguments */ 343 Tcl_Obj *CONST objv[]) /* Argument strings passed to Tcl_FileCmd. */ 344{ 345 int i, force, result; 346 Tcl_Obj *errfile; 347 Tcl_Obj *errorBuffer = NULL; 348 349 i = FileForceOption(interp, objc - 2, objv + 2, &force); 350 if (i < 0) { 351 return TCL_ERROR; 352 } 353 i += 2; 354 if ((objc - i) < 1) { 355 Tcl_AppendResult(interp, "wrong # args: should be \"", 356 TclGetString(objv[0]), " ", TclGetString(objv[1]), 357 " ?options? file ?file ...?\"", NULL); 358 return TCL_ERROR; 359 } 360 361 errfile = NULL; 362 result = TCL_OK; 363 364 for ( ; i < objc; i++) { 365 Tcl_StatBuf statBuf; 366 367 errfile = objv[i]; 368 if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) { 369 result = TCL_ERROR; 370 goto done; 371 } 372 373 /* 374 * Call lstat() to get info so can delete symbolic link itself. 375 */ 376 377 if (Tcl_FSLstat(objv[i], &statBuf) != 0) { 378 /* 379 * Trying to delete a file that does not exist is not considered 380 * an error, just a no-op 381 */ 382 383 if (errno != ENOENT) { 384 result = TCL_ERROR; 385 } 386 } else if (S_ISDIR(statBuf.st_mode)) { 387 /* 388 * We own a reference count on errorBuffer, if it was set as a 389 * result of this call. 390 */ 391 392 result = Tcl_FSRemoveDirectory(objv[i], force, &errorBuffer); 393 if (result != TCL_OK) { 394 if ((force == 0) && (errno == EEXIST)) { 395 Tcl_AppendResult(interp, "error deleting \"", 396 TclGetString(objv[i]), "\": directory not empty", 397 NULL); 398 Tcl_PosixError(interp); 399 goto done; 400 } 401 402 /* 403 * If possible, use the untranslated name for the file. 404 */ 405 406 errfile = errorBuffer; 407 408 /* 409 * FS supposed to check between translated objv and errfile. 410 */ 411 412 if (Tcl_FSEqualPaths(objv[i], errfile)) { 413 errfile = objv[i]; 414 } 415 } 416 } else { 417 result = Tcl_FSDeleteFile(objv[i]); 418 } 419 420 if (result != TCL_OK) { 421 result = TCL_ERROR; 422 423 /* 424 * It is important that we break on error, otherwise we might end 425 * up owning reference counts on numerous errorBuffers. 426 */ 427 428 break; 429 } 430 } 431 if (result != TCL_OK) { 432 if (errfile == NULL) { 433 /* 434 * We try to accomodate poor error results from our Tcl_FS calls. 435 */ 436 437 Tcl_AppendResult(interp, "error deleting unknown file: ", 438 Tcl_PosixError(interp), NULL); 439 } else { 440 Tcl_AppendResult(interp, "error deleting \"", 441 TclGetString(errfile), "\": ", Tcl_PosixError(interp), 442 NULL); 443 } 444 } 445 446 done: 447 if (errorBuffer != NULL) { 448 Tcl_DecrRefCount(errorBuffer); 449 } 450 return result; 451} 452 453/* 454 *--------------------------------------------------------------------------- 455 * 456 * CopyRenameOneFile 457 * 458 * Copies or renames specified source file or directory hierarchy to the 459 * specified target. 460 * 461 * Results: 462 * A standard Tcl result. 463 * 464 * Side effects: 465 * Target is overwritten if the force flag is set. Attempting to 466 * copy/rename a file onto a directory or a directory onto a file will 467 * always result in an error. 468 * 469 *---------------------------------------------------------------------- 470 */ 471 472static int 473CopyRenameOneFile( 474 Tcl_Interp *interp, /* Used for error reporting. */ 475 Tcl_Obj *source, /* Pathname of file to copy. May need to be 476 * translated. */ 477 Tcl_Obj *target, /* Pathname of file to create/overwrite. May 478 * need to be translated. */ 479 int copyFlag, /* If non-zero, copy files. Otherwise, rename 480 * them. */ 481 int force) /* If non-zero, overwrite target file if it 482 * exists. Otherwise, error if target already 483 * exists. */ 484{ 485 int result; 486 Tcl_Obj *errfile, *errorBuffer; 487 Tcl_Obj *actualSource=NULL; /* If source is a link, then this is the real 488 * file/directory. */ 489 Tcl_StatBuf sourceStatBuf, targetStatBuf; 490 491 if (Tcl_FSConvertToPathType(interp, source) != TCL_OK) { 492 return TCL_ERROR; 493 } 494 if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) { 495 return TCL_ERROR; 496 } 497 498 errfile = NULL; 499 errorBuffer = NULL; 500 result = TCL_ERROR; 501 502 /* 503 * We want to copy/rename links and not the files they point to, so we use 504 * lstat(). If target is a link, we also want to replace the link and not 505 * the file it points to, so we also use lstat() on the target. 506 */ 507 508 if (Tcl_FSLstat(source, &sourceStatBuf) != 0) { 509 errfile = source; 510 goto done; 511 } 512 if (Tcl_FSLstat(target, &targetStatBuf) != 0) { 513 if (errno != ENOENT) { 514 errfile = target; 515 goto done; 516 } 517 } else { 518 if (force == 0) { 519 errno = EEXIST; 520 errfile = target; 521 goto done; 522 } 523 524 /* 525 * Prevent copying or renaming a file onto itself. On Windows since 526 * 8.5 we do get an inode number, however the unsigned short field is 527 * insufficient to accept the Win32 API file id so it is truncated to 528 * 16 bits and we get collisions. See bug #2015723. 529 */ 530 531#ifndef WIN32 532 if ((sourceStatBuf.st_ino != 0) && (targetStatBuf.st_ino != 0)) { 533 if ((sourceStatBuf.st_ino == targetStatBuf.st_ino) && 534 (sourceStatBuf.st_dev == targetStatBuf.st_dev)) { 535 result = TCL_OK; 536 goto done; 537 } 538 } 539#endif 540 541 /* 542 * Prevent copying/renaming a file onto a directory and vice-versa. 543 * This is a policy decision based on the fact that existing 544 * implementations of copy and rename on all platforms also prevent 545 * this. 546 */ 547 548 if (S_ISDIR(sourceStatBuf.st_mode) 549 && !S_ISDIR(targetStatBuf.st_mode)) { 550 errno = EISDIR; 551 Tcl_AppendResult(interp, "can't overwrite file \"", 552 TclGetString(target), "\" with directory \"", 553 TclGetString(source), "\"", NULL); 554 goto done; 555 } 556 if (!S_ISDIR(sourceStatBuf.st_mode) 557 && S_ISDIR(targetStatBuf.st_mode)) { 558 errno = EISDIR; 559 Tcl_AppendResult(interp, "can't overwrite directory \"", 560 TclGetString(target), "\" with file \"", 561 TclGetString(source), "\"", NULL); 562 goto done; 563 } 564 565 /* 566 * The destination exists, but appears to be ok to over-write, and 567 * -force is given. We now try to adjust permissions to ensure the 568 * operation succeeds. If we can't adjust permissions, we'll let the 569 * actual copy/rename return an error later. 570 */ 571 572 { 573 Tcl_Obj *perm; 574 int index; 575 576 TclNewLiteralStringObj(perm, "u+w"); 577 Tcl_IncrRefCount(perm); 578 if (TclFSFileAttrIndex(target, "-permissions", &index) == TCL_OK) { 579 Tcl_FSFileAttrsSet(NULL, index, target, perm); 580 } 581 Tcl_DecrRefCount(perm); 582 } 583 } 584 585 if (copyFlag == 0) { 586 result = Tcl_FSRenameFile(source, target); 587 if (result == TCL_OK) { 588 goto done; 589 } 590 591 if (errno == EINVAL) { 592 Tcl_AppendResult(interp, "error renaming \"", 593 TclGetString(source), "\" to \"", TclGetString(target), 594 "\": trying to rename a volume or " 595 "move a directory into itself", NULL); 596 goto done; 597 } else if (errno != EXDEV) { 598 errfile = target; 599 goto done; 600 } 601 602 /* 603 * The rename failed because the move was across file systems. Fall 604 * through to copy file and then remove original. Note that the 605 * low-level Tcl_FSRenameFileProc in the filesystem is allowed to 606 * implement cross-filesystem moves itself, if it desires. 607 */ 608 } 609 610 actualSource = source; 611 Tcl_IncrRefCount(actualSource); 612 613 /* 614 * Activate the following block to copy files instead of links. However 615 * Tcl's semantics currently say we should copy links, so any such change 616 * should be the subject of careful study on the consequences. 617 * 618 * Perhaps there could be an optional flag to 'file copy' to dictate which 619 * approach to use, with the default being _not_ to have this block 620 * active. 621 */ 622 623#if 0 624#ifdef S_ISLNK 625 if (copyFlag && S_ISLNK(sourceStatBuf.st_mode)) { 626 /* 627 * We want to copy files not links. Therefore we must follow the link. 628 * There are two purposes to this 'stat' call here. First we want to 629 * know if the linked-file/dir actually exists, and second, in the 630 * block of code which follows, some 20 lines down, we want to check 631 * if the thing is a file or directory. 632 */ 633 634 if (Tcl_FSStat(source, &sourceStatBuf) != 0) { 635 /* 636 * Actual file doesn't exist. 637 */ 638 639 Tcl_AppendResult(interp, "error copying \"", TclGetString(source), 640 "\": the target of this link doesn't exist", NULL); 641 goto done; 642 } else { 643 int counter = 0; 644 645 while (1) { 646 Tcl_Obj *path = Tcl_FSLink(actualSource, NULL, 0); 647 if (path == NULL) { 648 break; 649 } 650 651 /* 652 * Now we want to check if this is a relative path, and if so, 653 * to make it absolute. 654 */ 655 656 if (Tcl_FSGetPathType(path) == TCL_PATH_RELATIVE) { 657 Tcl_Obj *abs = Tcl_FSJoinToPath(actualSource, 1, &path); 658 659 if (abs == NULL) { 660 break; 661 } 662 Tcl_IncrRefCount(abs); 663 Tcl_DecrRefCount(path); 664 path = abs; 665 } 666 Tcl_DecrRefCount(actualSource); 667 actualSource = path; 668 counter++; 669 670 /* 671 * Arbitrary limit of 20 links to follow. 672 */ 673 674 if (counter > 20) { 675 /* 676 * Too many links. 677 */ 678 679 Tcl_SetErrno(EMLINK); 680 errfile = source; 681 goto done; 682 } 683 } 684 /* Now 'actualSource' is the correct file */ 685 } 686 } 687#endif /* S_ISLNK */ 688#endif 689 690 if (S_ISDIR(sourceStatBuf.st_mode)) { 691 result = Tcl_FSCopyDirectory(actualSource, target, &errorBuffer); 692 if (result != TCL_OK) { 693 if (errno == EXDEV) { 694 /* 695 * The copy failed because we're trying to do a 696 * cross-filesystem copy. We do this through our Tcl library. 697 */ 698 699 Tcl_Obj *copyCommand, *cmdObj, *opObj; 700 701 TclNewObj(copyCommand); 702 TclNewLiteralStringObj(cmdObj, "::tcl::CopyDirectory"); 703 Tcl_ListObjAppendElement(interp, copyCommand, cmdObj); 704 if (copyFlag) { 705 TclNewLiteralStringObj(opObj, "copying"); 706 } else { 707 TclNewLiteralStringObj(opObj, "renaming"); 708 } 709 Tcl_ListObjAppendElement(interp, copyCommand, opObj); 710 Tcl_ListObjAppendElement(interp, copyCommand, source); 711 Tcl_ListObjAppendElement(interp, copyCommand, target); 712 Tcl_IncrRefCount(copyCommand); 713 result = Tcl_EvalObjEx(interp, copyCommand, 714 TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); 715 Tcl_DecrRefCount(copyCommand); 716 if (result != TCL_OK) { 717 /* 718 * There was an error in the Tcl-level copy. We will pass 719 * on the Tcl error message and can ensure this by setting 720 * errfile to NULL 721 */ 722 723 errfile = NULL; 724 } 725 } else { 726 errfile = errorBuffer; 727 if (Tcl_FSEqualPaths(errfile, source)) { 728 errfile = source; 729 } else if (Tcl_FSEqualPaths(errfile, target)) { 730 errfile = target; 731 } 732 } 733 } 734 } else { 735 result = Tcl_FSCopyFile(actualSource, target); 736 if ((result != TCL_OK) && (errno == EXDEV)) { 737 result = TclCrossFilesystemCopy(interp, source, target); 738 } 739 if (result != TCL_OK) { 740 /* 741 * We could examine 'errno' to double-check if the problem was 742 * with the target, but we checked the source above, so it should 743 * be quite clear 744 */ 745 746 errfile = target; 747 748 /* 749 * We now need to reset the result, because the above call, if it 750 * failed, may have put an error message in place. (Ideally we 751 * would prefer not to pass an interpreter in above, but the 752 * channel IO code used by TclCrossFilesystemCopy currently 753 * requires one). 754 */ 755 756 Tcl_ResetResult(interp); 757 } 758 } 759 if ((copyFlag == 0) && (result == TCL_OK)) { 760 if (S_ISDIR(sourceStatBuf.st_mode)) { 761 result = Tcl_FSRemoveDirectory(source, 1, &errorBuffer); 762 if (result != TCL_OK) { 763 if (Tcl_FSEqualPaths(errfile, source) == 0) { 764 errfile = source; 765 } 766 } 767 } else { 768 result = Tcl_FSDeleteFile(source); 769 if (result != TCL_OK) { 770 errfile = source; 771 } 772 } 773 if (result != TCL_OK) { 774 Tcl_AppendResult(interp, "can't unlink \"", TclGetString(errfile), 775 "\": ", Tcl_PosixError(interp), NULL); 776 errfile = NULL; 777 } 778 } 779 780 done: 781 if (errfile != NULL) { 782 Tcl_AppendResult(interp, "error ", (copyFlag ? "copying" : "renaming"), 783 " \"", TclGetString(source), NULL); 784 if (errfile != source) { 785 Tcl_AppendResult(interp, "\" to \"", TclGetString(target), NULL); 786 if (errfile != target) { 787 Tcl_AppendResult(interp, "\": \"", TclGetString(errfile),NULL); 788 } 789 } 790 Tcl_AppendResult(interp, "\": ", Tcl_PosixError(interp), NULL); 791 } 792 if (errorBuffer != NULL) { 793 Tcl_DecrRefCount(errorBuffer); 794 } 795 if (actualSource != NULL) { 796 Tcl_DecrRefCount(actualSource); 797 } 798 return result; 799} 800 801/* 802 *--------------------------------------------------------------------------- 803 * 804 * FileForceOption -- 805 * 806 * Helps parse command line options for file commands that take the 807 * "-force" and "--" options. 808 * 809 * Results: 810 * The return value is how many arguments from argv were consumed by this 811 * function, or -1 if there was an error parsing the options. If an error 812 * occurred, an error message is left in the interp's result. 813 * 814 * Side effects: 815 * None. 816 * 817 *--------------------------------------------------------------------------- 818 */ 819 820static int 821FileForceOption( 822 Tcl_Interp *interp, /* Interp, for error return. */ 823 int objc, /* Number of arguments. */ 824 Tcl_Obj *CONST objv[], /* Argument strings. First command line 825 * option, if it exists, begins at 0. */ 826 int *forcePtr) /* If the "-force" was specified, *forcePtr is 827 * filled with 1, otherwise with 0. */ 828{ 829 int force, i; 830 831 force = 0; 832 for (i = 0; i < objc; i++) { 833 if (TclGetString(objv[i])[0] != '-') { 834 break; 835 } 836 if (strcmp(TclGetString(objv[i]), "-force") == 0) { 837 force = 1; 838 } else if (strcmp(TclGetString(objv[i]), "--") == 0) { 839 i++; 840 break; 841 } else { 842 Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[i]), 843 "\": should be -force or --", NULL); 844 return -1; 845 } 846 } 847 *forcePtr = force; 848 return i; 849} 850/* 851 *--------------------------------------------------------------------------- 852 * 853 * FileBasename -- 854 * 855 * Given a path in either tcl format (with / separators), or in the 856 * platform-specific format for the current platform, return all the 857 * characters in the path after the last directory separator. But, if 858 * path is the root directory, returns no characters. 859 * 860 * Results: 861 * Returns the string object that represents the basename. If there is an 862 * error, an error message is left in interp, and NULL is returned. 863 * 864 * Side effects: 865 * None. 866 * 867 *--------------------------------------------------------------------------- 868 */ 869 870static Tcl_Obj * 871FileBasename( 872 Tcl_Interp *interp, /* Interp, for error return. */ 873 Tcl_Obj *pathPtr) /* Path whose basename to extract. */ 874{ 875 int objc; 876 Tcl_Obj *splitPtr; 877 Tcl_Obj *resultPtr = NULL; 878 879 splitPtr = Tcl_FSSplitPath(pathPtr, &objc); 880 Tcl_IncrRefCount(splitPtr); 881 882 if (objc != 0) { 883 if ((objc == 1) && (*TclGetString(pathPtr) == '~')) { 884 Tcl_DecrRefCount(splitPtr); 885 if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) { 886 return NULL; 887 } 888 splitPtr = Tcl_FSSplitPath(pathPtr, &objc); 889 Tcl_IncrRefCount(splitPtr); 890 } 891 892 /* 893 * Return the last component, unless it is the only component, and it 894 * is the root of an absolute path. 895 */ 896 897 if (objc > 0) { 898 Tcl_ListObjIndex(NULL, splitPtr, objc-1, &resultPtr); 899 if ((objc == 1) && 900 (Tcl_FSGetPathType(resultPtr) != TCL_PATH_RELATIVE)) { 901 resultPtr = NULL; 902 } 903 } 904 } 905 if (resultPtr == NULL) { 906 resultPtr = Tcl_NewObj(); 907 } 908 Tcl_IncrRefCount(resultPtr); 909 Tcl_DecrRefCount(splitPtr); 910 return resultPtr; 911} 912 913/* 914 *---------------------------------------------------------------------- 915 * 916 * TclFileAttrsCmd -- 917 * 918 * Sets or gets the platform-specific attributes of a file. The objc-objv 919 * points to the file name with the rest of the command line following. 920 * This routine uses platform-specific tables of option strings and 921 * callbacks. The callback to get the attributes take three parameters: 922 * Tcl_Interp *interp; The interp to report errors with. Since 923 * this is an object-based API, the object 924 * form of the result should be used. 925 * CONST char *fileName; This is extracted using 926 * Tcl_TranslateFileName. 927 * TclObj **attrObjPtrPtr; A new object to hold the attribute is 928 * allocated and put here. 929 * The first two parameters of the callback used to write out the 930 * attributes are the same. The third parameter is: 931 * CONST *attrObjPtr; A pointer to the object that has the new 932 * attribute. 933 * They both return standard TCL errors; if the routine to get an 934 * attribute fails, no object is allocated and *attrObjPtrPtr is 935 * unchanged. 936 * 937 * Results: 938 * Standard TCL error. 939 * 940 * Side effects: 941 * May set file attributes for the file name. 942 * 943 *---------------------------------------------------------------------- 944 */ 945 946int 947TclFileAttrsCmd( 948 Tcl_Interp *interp, /* The interpreter for error reporting. */ 949 int objc, /* Number of command line arguments. */ 950 Tcl_Obj *CONST objv[]) /* The command line objects. */ 951{ 952 int result; 953 CONST char ** attributeStrings; 954 Tcl_Obj* objStrings = NULL; 955 int numObjStrings = -1; 956 Tcl_Obj *filePtr; 957 958 if (objc < 3) { 959 Tcl_WrongNumArgs(interp, 2, objv, 960 "name ?option? ?value? ?option value ...?"); 961 return TCL_ERROR; 962 } 963 964 filePtr = objv[2]; 965 if (Tcl_FSConvertToPathType(interp, filePtr) != TCL_OK) { 966 return TCL_ERROR; 967 } 968 969 objc -= 3; 970 objv += 3; 971 result = TCL_ERROR; 972 Tcl_SetErrno(0); 973 974 attributeStrings = Tcl_FSFileAttrStrings(filePtr, &objStrings); 975 if (attributeStrings == NULL) { 976 int index; 977 Tcl_Obj *objPtr; 978 979 if (objStrings == NULL) { 980 if (Tcl_GetErrno() != 0) { 981 /* 982 * There was an error, probably that the filePtr is not 983 * accepted by any filesystem 984 */ 985 Tcl_AppendResult(interp, "could not read \"", 986 TclGetString(filePtr), "\": ", Tcl_PosixError(interp), 987 NULL); 988 return TCL_ERROR; 989 } 990 goto end; 991 } 992 993 /* 994 * We own the object now. 995 */ 996 997 Tcl_IncrRefCount(objStrings); 998 999 /* 1000 * Use objStrings as a list object. 1001 */ 1002 1003 if (Tcl_ListObjLength(interp, objStrings, &numObjStrings) != TCL_OK) { 1004 goto end; 1005 } 1006 attributeStrings = (CONST char **) TclStackAlloc(interp, 1007 (1+numObjStrings) * sizeof(char*)); 1008 for (index = 0; index < numObjStrings; index++) { 1009 Tcl_ListObjIndex(interp, objStrings, index, &objPtr); 1010 attributeStrings[index] = TclGetString(objPtr); 1011 } 1012 attributeStrings[index] = NULL; 1013 } 1014 if (objc == 0) { 1015 /* 1016 * Get all attributes. 1017 */ 1018 1019 int index, res = TCL_OK, nbAtts = 0; 1020 Tcl_Obj *listPtr; 1021 1022 listPtr = Tcl_NewListObj(0, NULL); 1023 for (index = 0; attributeStrings[index] != NULL; index++) { 1024 Tcl_Obj *objPtrAttr; 1025 1026 if (res != TCL_OK) { 1027 /* 1028 * Clear the error from the last iteration. 1029 */ 1030 1031 Tcl_ResetResult(interp); 1032 } 1033 1034 res = Tcl_FSFileAttrsGet(interp, index, filePtr, &objPtrAttr); 1035 if (res == TCL_OK) { 1036 Tcl_Obj *objPtr = 1037 Tcl_NewStringObj(attributeStrings[index], -1); 1038 1039 Tcl_ListObjAppendElement(interp, listPtr, objPtr); 1040 Tcl_ListObjAppendElement(interp, listPtr, objPtrAttr); 1041 nbAtts++; 1042 } 1043 } 1044 1045 if (index > 0 && nbAtts == 0) { 1046 /* 1047 * Error: no valid attributes found. 1048 */ 1049 1050 Tcl_DecrRefCount(listPtr); 1051 goto end; 1052 } 1053 1054 Tcl_SetObjResult(interp, listPtr); 1055 } else if (objc == 1) { 1056 /* 1057 * Get one attribute. 1058 */ 1059 1060 int index; 1061 Tcl_Obj *objPtr = NULL; 1062 1063 if (numObjStrings == 0) { 1064 Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[0]), 1065 "\", there are no file attributes in this filesystem.", 1066 NULL); 1067 goto end; 1068 } 1069 1070 if (Tcl_GetIndexFromObj(interp, objv[0], attributeStrings, 1071 "option", 0, &index) != TCL_OK) { 1072 goto end; 1073 } 1074 if (Tcl_FSFileAttrsGet(interp, index, filePtr, 1075 &objPtr) != TCL_OK) { 1076 goto end; 1077 } 1078 Tcl_SetObjResult(interp, objPtr); 1079 } else { 1080 /* 1081 * Set option/value pairs. 1082 */ 1083 1084 int i, index; 1085 1086 if (numObjStrings == 0) { 1087 Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[0]), 1088 "\", there are no file attributes in this filesystem.", 1089 NULL); 1090 goto end; 1091 } 1092 1093 for (i = 0; i < objc ; i += 2) { 1094 if (Tcl_GetIndexFromObj(interp, objv[i], attributeStrings, 1095 "option", 0, &index) != TCL_OK) { 1096 goto end; 1097 } 1098 if (i + 1 == objc) { 1099 Tcl_AppendResult(interp, "value for \"", 1100 TclGetString(objv[i]), "\" missing", NULL); 1101 goto end; 1102 } 1103 if (Tcl_FSFileAttrsSet(interp, index, filePtr, 1104 objv[i + 1]) != TCL_OK) { 1105 goto end; 1106 } 1107 } 1108 } 1109 result = TCL_OK; 1110 1111 end: 1112 if (numObjStrings != -1) { 1113 /* 1114 * Free up the array we allocated. 1115 */ 1116 1117 TclStackFree(interp, (void *)attributeStrings); 1118 1119 /* 1120 * We don't need this object that was passed to us any more. 1121 */ 1122 1123 if (objStrings != NULL) { 1124 Tcl_DecrRefCount(objStrings); 1125 } 1126 } 1127 return result; 1128} 1129 1130/* 1131 * Local Variables: 1132 * mode: c 1133 * c-basic-offset: 4 1134 * fill-column: 78 1135 * End: 1136 */ 1137