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 d0f1daac754e8554f1d746a65f1ed1e6b424ce82:


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