Tcl Source Code

Artifact Content
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Artifact ee3766c8dd7733163cd323e159552f59138990ef7690e553aeb8f28ffdb4740b:


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