summaryrefslogtreecommitdiffstats
path: root/generic/tclPathObj.c
Commit message (Expand)AuthorAgeFilesLines
* * generic/tclOOMethod.c (ProcedureMethodCompiledVarConnect):hobbs2010-09-221-9/+13
* Code Audit results:dkf2010-03-051-21/+23
* Pure whitespace changes, changing to follow Engineering Manual style.dkf2010-02-241-2/+2
* * generic/tclPathObj.c (TclPathPart): Correct inconsistency betweendgp2010-01-051-26/+10
* Various CYGWIN-related fixes. In the win32 configure script, CYGWIN is still ...nijtmans2009-12-211-3/+15
* * generic/tclPathObj.c: Missing refcount on cached normalized pathdgp2009-10-271-1/+2
* * generic/tclDictObj.c: Updated freeIntRepProc routines sodgp2009-09-301-1/+2
* * generic/tclPathObj.c: [Bug 2806250] Prevent the storage of stringsdgp2009-08-201-149/+80
* * generic/tclPathObj.c: Added NULL check to prevent crashes duringdgp2009-08-181-1/+4
* * generic/tclPathObj.c (TclPathPart): TclPathPart() was computingdgp2009-03-271-3/+29
* * generic/tclPathObj.c: Fixed mistaken logic in TclFSGetPathType()dgp2009-02-201-1/+10
* - eliminate some unnessary type castsnijtmans2009-02-101-2/+2
* Style fixes (unfouling whitespace, sorting comments, removing useless casts, ...dkf2009-01-091-67/+71
* * generic/tclPathObj.c (Tcl_FSGetNormalizedPath): Added anotherdgp2008-12-041-13/+76
* Style improvements - invoking callbacks without visual junk.dkf2008-10-261-6/+8
* Add "const" to many internalnijtmans2008-10-161-2/+2
* * doc/FileSystem.3: CONSTified many functions using Tcl_FileSystemnijtmans2008-07-281-6/+6
* * generic/tclPathObj.c: Plug memory leak in [Bug 1999176] fix. Thanksdgp2008-06-291-3/+7
* * generic/tclPathObj.c: Plug memory leak in [Bug 1972879] fix. Thanksdgp2008-06-281-3/+7
* * generic/tclPathObj.c: Fixed some internals management in the "path"dgp2008-06-241-2/+25
* * generic/tclPathObj.c: Fixed bug in Tcl_GetTranslatedPath() whendgp2008-06-231-7/+9
* * generic/tclPathObj.c: Fixed bug in Tcl_GetTranslatedPath() whendgp2008-06-231-2/+9
* Get rid of pre-C89-isms (esp. CONST vs const).dkf2008-04-271-2/+2
* merge stable branch onto HEADdgp2007-12-131-1/+1
* Reduce cast count.dkf2007-11-191-109/+102
* More minor cleanupdkf2007-11-181-6/+6
* * generic/tclPathObj.c (Tcl_FSJoinPath, Tcl_FSGetNormalizedPath):Kevin B Kenny2007-05-021-3/+10
* Replaced commas in varargs with string concatenation where possible [Patch 15...Kevin B Kenny2007-04-201-4/+4
* * doc/clock.n: Corrected a silly error (transposed 'uppercase'Kevin B Kenny2007-04-201-2/+3
* Eliminate use of (VOID*) casts when calling memset or memcpy.dkf2007-04-171-3/+3
* Handle creation of Tcl_Objs from constant strings better (easier to use, moredkf2007-04-101-2/+2
* various "const" additions, in line with TIP #27nijtmans2007-02-201-26/+26
* Bug #1479814. Handle extended paths on Windows NT and above.patthoyts2007-02-201-1/+16
* fixed [ 1548263 ] NULL return from Tcl_FSGetNormalizedPath segvcoldstore2006-08-291-2/+4
* * generic/tclPathObj.c: Yet another revised fix for the [Bug 1379287]dgp2006-04-071-5/+12
* * generic/tclPathObj.c: Revised fix for the [Bug 1379287] familydgp2006-04-061-30/+19
* * generic/tclPathObj.c: More fixes for path normalization when /../dgp2006-03-291-9/+15
* another stab at fixing 1379287dgp2006-03-041-6/+13
* * generic/tclPathObj.c: Revised yesterday's fix for [Bug 1379287]dgp2006-03-031-4/+6
* * generic/tclPathObj.c: Fix for failed normalization ofdgp2006-03-031-2/+10
* Fixed potential overwriting of already freed memoryvasiljevic2006-01-121-3/+7
* * unix/tcl.m4 (Darwin): add 64bit support, check for Tiger copyfile(),das2005-11-271-2/+2
* Formatting and pure ANSI function declsdkf2005-10-121-152/+161
* Fix for [Bug 1325099]dkf2005-10-121-2/+2
* More informative comment.dkf2005-08-091-2/+6
* added nul-termination missing from earlier commit todaydgp2005-08-091-1/+2
* file rootname bug fixvincentdarley2005-08-081-2/+5
* Systematizing the formattingdkf2005-07-211-881/+932
* Merged kennykb-numerics-branch back to the head; TIPs 132 and 232Kevin B Kenny2005-05-101-1/+1
* * doc/Thread.3: Fixed sentence describing flags for Tcl_CreateThread.davidw2005-02-051-2/+2
generated by cgit v0.12 at 2024-08-19 21:29:16 (GMT)
6'>646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 
/*
 * tclFCmd.c
 *
 *	This file implements the generic portion of file manipulation
 *	subcommands of the "file" command.
 *
 * Copyright (c) 1996-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include "tclInt.h"

/*
 * Declarations for local functions defined in this file:
 */

static int		CopyRenameOneFile(Tcl_Interp *interp,
			    Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr,
			    int copyFlag, int force);
static Tcl_Obj *	FileBasename(Tcl_Interp *interp, Tcl_Obj *pathPtr);
static int		FileCopyRename(Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[], int copyFlag);
static int		FileForceOption(Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[], int *forcePtr);

/*
 *---------------------------------------------------------------------------
 *
 * TclFileRenameCmd
 *
 *	This function implements the "rename" subcommand of the "file"
 *	command. Filename arguments need to be translated to native format
 *	before being passed to platform-specific code that implements rename
 *	functionality.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *---------------------------------------------------------------------------
 */

int
TclFileRenameCmd(
    Tcl_Interp *interp,		/* Interp for error reporting or recursive
				 * calls in the case of a tricky rename. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *CONST objv[])	/* Argument strings passed to Tcl_FileCmd. */
{
    return FileCopyRename(interp, objc, objv, 0);
}

/*
 *---------------------------------------------------------------------------
 *
 * TclFileCopyCmd
 *
 *	This function implements the "copy" subcommand of the "file" command.
 *	Filename arguments need to be translated to native format before being
 *	passed to platform-specific code that implements copy functionality.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *---------------------------------------------------------------------------
 */

int
TclFileCopyCmd(
    Tcl_Interp *interp,		/* Used for error reporting or recursive calls
				 * in the case of a tricky copy. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *CONST objv[])	/* Argument strings passed to Tcl_FileCmd. */
{
    return FileCopyRename(interp, objc, objv, 1);
}

/*
 *---------------------------------------------------------------------------
 *
 * FileCopyRename --
 *
 *	Performs the work of TclFileRenameCmd and TclFileCopyCmd. See
 *	comments for those functions.
 *
 * Results:
 *	See above.
 *
 * Side effects:
 *	See above.
 *
 *---------------------------------------------------------------------------
 */

static int
FileCopyRename(
    Tcl_Interp *interp,		/* Used for error reporting. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *CONST objv[],	/* Argument strings passed to Tcl_FileCmd. */
    int copyFlag)		/* If non-zero, copy source(s). Otherwise,
				 * rename them. */
{
    int i, result, force;
    Tcl_StatBuf statBuf;
    Tcl_Obj *target;

    i = FileForceOption(interp, objc - 2, objv + 2, &force);
    if (i < 0) {
	return TCL_ERROR;
    }
    i += 2;
    if ((objc - i) < 2) {
	Tcl_AppendResult(interp, "wrong # args: should be \"",
		TclGetString(objv[0]), " ", TclGetString(objv[1]),
		" ?options? source ?source ...? target\"", NULL);
	return TCL_ERROR;
    }

    /*
     * If target doesn't exist or isn't a directory, try the copy/rename.
     * More than 2 arguments is only valid if the target is an existing
     * directory.
     */

    target = objv[objc - 1];
    if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) {
	return TCL_ERROR;
    }

    result = TCL_OK;

    /*
     * Call Tcl_FSStat() so that if target is a symlink that points to a
     * directory we will put the sources in that directory instead of
     * overwriting the symlink.
     */

    if ((Tcl_FSStat(target, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) {
	if ((objc - i) > 2) {
	    errno = ENOTDIR;
	    Tcl_PosixError(interp);
	    Tcl_AppendResult(interp, "error ",
		    (copyFlag ? "copying" : "renaming"), ": target \"",
		    TclGetString(target), "\" is not a directory", NULL);
	    result = TCL_ERROR;
	} else {
	    /*
	     * Even though already have target == translated(objv[i+1]), pass
	     * the original argument down, so if there's an error, the error
	     * message will reflect the original arguments.
	     */

	    result = CopyRenameOneFile(interp, objv[i], objv[i + 1], copyFlag,
		    force);
	}
	return result;
    }

    /*
     * Move each source file into target directory. Extract the basename from
     * each source, and append it to the end of the target path.
     */

    for ( ; i<objc-1 ; i++) {
	Tcl_Obj *jargv[2];
	Tcl_Obj *source, *newFileName;
	Tcl_Obj *temp;

	source = FileBasename(interp, objv[i]);
	if (source == NULL) {
	    result = TCL_ERROR;
	    break;
	}
	jargv[0] = objv[objc - 1];
	jargv[1] = source;
	temp = Tcl_NewListObj(2, jargv);
	newFileName = Tcl_FSJoinPath(temp, -1);
	Tcl_IncrRefCount(newFileName);
	result = CopyRenameOneFile(interp, objv[i], newFileName, copyFlag,
		force);
	Tcl_DecrRefCount(newFileName);
	Tcl_DecrRefCount(temp);
	Tcl_DecrRefCount(source);

	if (result == TCL_ERROR) {
	    break;
	}
    }
    return result;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclFileMakeDirsCmd
 *
 *	This function implements the "mkdir" subcommand of the "file" command.
 *	Filename arguments need to be translated to native format before being
 *	passed to platform-specific code that implements mkdir functionality.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

int
TclFileMakeDirsCmd(
    Tcl_Interp *interp,		/* Used for error reporting. */
    int objc,			/* Number of arguments */
    Tcl_Obj *CONST objv[])	/* Argument strings passed to Tcl_FileCmd. */
{
    Tcl_Obj *errfile;
    int result, i, j, pobjc;
    Tcl_Obj *split = NULL;
    Tcl_Obj *target = NULL;
    Tcl_StatBuf statBuf;

    errfile = NULL;

    result = TCL_OK;
    for (i = 2; i < objc; i++) {
	if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) {
	    result = TCL_ERROR;
	    break;
	}

	split = Tcl_FSSplitPath(objv[i],&pobjc);
	Tcl_IncrRefCount(split);
	if (pobjc == 0) {
	    errno = ENOENT;
	    errfile = objv[i];
	    break;
	}
	for (j = 0; j < pobjc; j++) {
	    target = Tcl_FSJoinPath(split, j + 1);
	    Tcl_IncrRefCount(target);

	    /*
	     * Call Tcl_FSStat() so that if target is a symlink that points to
	     * a directory we will create subdirectories in that directory.
	     */

	    if (Tcl_FSStat(target, &statBuf) == 0) {
		if (!S_ISDIR(statBuf.st_mode)) {
		    errno = EEXIST;
		    errfile = target;
		    goto done;
		}
	    } else if (errno != ENOENT) {
		/*
		 * If Tcl_FSStat() failed and the error is anything other than
		 * non-existence of the target, throw the error.
		 */

		errfile = target;
		goto done;
	    } else if (Tcl_FSCreateDirectory(target) != TCL_OK) {
		/*
		 * Create might have failed because of being in a race
		 * condition with another process trying to create the same
		 * subdirectory.
		 */

		if (errno == EEXIST) {
		    if ((Tcl_FSStat(target, &statBuf) == 0)
			    && S_ISDIR(statBuf.st_mode)) {
			/*
			 * It is a directory that wasn't there before, so keep
			 * going without error.
			 */

			Tcl_ResetResult(interp);
		    } else {
			errfile = target;
			goto done;
		    }
		} else {
		    errfile = target;
		    goto done;
		}
	    }

	    /*
	     * Forget about this sub-path.
	     */

	    Tcl_DecrRefCount(target);
	    target = NULL;
	}
	Tcl_DecrRefCount(split);
	split = NULL;
    }

  done:
    if (errfile != NULL) {
	Tcl_AppendResult(interp, "can't create directory \"",
		TclGetString(errfile), "\": ", Tcl_PosixError(interp), NULL);
	result = TCL_ERROR;
    }
    if (split != NULL) {
	Tcl_DecrRefCount(split);
    }
    if (target != NULL) {
	Tcl_DecrRefCount(target);
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TclFileDeleteCmd
 *
 *	This function implements the "delete" subcommand of the "file"
 *	command.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

int
TclFileDeleteCmd(
    Tcl_Interp *interp,		/* Used for error reporting */
    int objc,			/* Number of arguments */
    Tcl_Obj *CONST objv[])	/* Argument strings passed to Tcl_FileCmd. */
{
    int i, force, result;
    Tcl_Obj *errfile;
    Tcl_Obj *errorBuffer = NULL;

    i = FileForceOption(interp, objc - 2, objv + 2, &force);
    if (i < 0) {
	return TCL_ERROR;
    }
    i += 2;
    if ((objc - i) < 1) {
	Tcl_AppendResult(interp, "wrong # args: should be \"",
		TclGetString(objv[0]), " ", TclGetString(objv[1]),
		" ?options? file ?file ...?\"", NULL);
	return TCL_ERROR;
    }

    errfile = NULL;
    result = TCL_OK;

    for ( ; i < objc; i++) {
	Tcl_StatBuf statBuf;

	errfile = objv[i];
	if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) {
	    result = TCL_ERROR;
	    goto done;
	}

	/*
	 * Call lstat() to get info so can delete symbolic link itself.
	 */

	if (Tcl_FSLstat(objv[i], &statBuf) != 0) {
	    /*
	     * Trying to delete a file that does not exist is not considered
	     * an error, just a no-op
	     */

	    if (errno != ENOENT) {
		result = TCL_ERROR;
	    }
	} else if (S_ISDIR(statBuf.st_mode)) {
	    /*
	     * We own a reference count on errorBuffer, if it was set as a
	     * result of this call.
	     */

	    result = Tcl_FSRemoveDirectory(objv[i], force, &errorBuffer);
	    if (result != TCL_OK) {
		if ((force == 0) && (errno == EEXIST)) {
		    Tcl_AppendResult(interp, "error deleting \"",
			    TclGetString(objv[i]), "\": directory not empty",
			    NULL);
		    Tcl_PosixError(interp);
		    goto done;
		}

		/*
		 * If possible, use the untranslated name for the file.
		 */

		errfile = errorBuffer;

		/*
		 * FS supposed to check between translated objv and errfile.
		 */

		if (Tcl_FSEqualPaths(objv[i], errfile)) {
		    errfile = objv[i];
		}
	    }
	} else {
	    result = Tcl_FSDeleteFile(objv[i]);
	}

	if (result != TCL_OK) {
	    result = TCL_ERROR;

	    /*
	     * It is important that we break on error, otherwise we might end
	     * up owning reference counts on numerous errorBuffers.
	     */

	    break;
	}
    }
    if (result != TCL_OK) {
	if (errfile == NULL) {
	    /*
	     * We try to accomodate poor error results from our Tcl_FS calls.
	     */

	    Tcl_AppendResult(interp, "error deleting unknown file: ",
		    Tcl_PosixError(interp), NULL);
	} else {
	    Tcl_AppendResult(interp, "error deleting \"",
		    TclGetString(errfile), "\": ", Tcl_PosixError(interp),
		    NULL);
	}
    }

  done:
    if (errorBuffer != NULL) {
	Tcl_DecrRefCount(errorBuffer);
    }
    return result;
}

/*
 *---------------------------------------------------------------------------
 *
 * CopyRenameOneFile
 *
 *	Copies or renames specified source file or directory hierarchy to the
 *	specified target.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Target is overwritten if the force flag is set. Attempting to
 *	copy/rename a file onto a directory or a directory onto a file will
 *	always result in an error.
 *
 *----------------------------------------------------------------------
 */

static int
CopyRenameOneFile(
    Tcl_Interp *interp,		/* Used for error reporting. */
    Tcl_Obj *source,		/* Pathname of file to copy. May need to be
				 * translated. */
    Tcl_Obj *target,		/* Pathname of file to create/overwrite. May
				 * need to be translated. */
    int copyFlag,		/* If non-zero, copy files. Otherwise, rename
				 * them. */
    int force)			/* If non-zero, overwrite target file if it
				 * exists. Otherwise, error if target already
				 * exists. */
{
    int result;
    Tcl_Obj *errfile, *errorBuffer;
    Tcl_Obj *actualSource=NULL;	/* If source is a link, then this is the real
				 * file/directory. */
    Tcl_StatBuf sourceStatBuf, targetStatBuf;

    if (Tcl_FSConvertToPathType(interp, source) != TCL_OK) {
	return TCL_ERROR;
    }
    if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) {
	return TCL_ERROR;
    }

    errfile = NULL;
    errorBuffer = NULL;
    result = TCL_ERROR;

    /*
     * We want to copy/rename links and not the files they point to, so we use
     * lstat(). If target is a link, we also want to replace the link and not
     * the file it points to, so we also use lstat() on the target.
     */

    if (Tcl_FSLstat(source, &sourceStatBuf) != 0) {
	errfile = source;
	goto done;
    }
    if (Tcl_FSLstat(target, &targetStatBuf) != 0) {
	if (errno != ENOENT) {
	    errfile = target;
	    goto done;
	}
    } else {
	if (force == 0) {
	    errno = EEXIST;
	    errfile = target;
	    goto done;
	}

	/*
	 * Prevent copying or renaming a file onto itself. On Windows since
	 * 8.5 we do get an inode number, however the unsigned short field is
	 * insufficient to accept the Win32 API file id so it is truncated to
	 * 16 bits and we get collisions. See bug #2015723.
	 */

#ifndef WIN32
	if ((sourceStatBuf.st_ino != 0) && (targetStatBuf.st_ino != 0)) {
	    if ((sourceStatBuf.st_ino == targetStatBuf.st_ino) &&
		    (sourceStatBuf.st_dev == targetStatBuf.st_dev)) {
		result = TCL_OK;
		goto done;
	    }
	}
#endif

	/*
	 * Prevent copying/renaming a file onto a directory and vice-versa.
	 * This is a policy decision based on the fact that existing
	 * implementations of copy and rename on all platforms also prevent
	 * this.
	 */

	if (S_ISDIR(sourceStatBuf.st_mode)
		&& !S_ISDIR(targetStatBuf.st_mode)) {
	    errno = EISDIR;
	    Tcl_AppendResult(interp, "can't overwrite file \"",
		    TclGetString(target), "\" with directory \"",
		    TclGetString(source), "\"", NULL);
	    goto done;
	}
	if (!S_ISDIR(sourceStatBuf.st_mode)
		&& S_ISDIR(targetStatBuf.st_mode)) {
	    errno = EISDIR;
	    Tcl_AppendResult(interp, "can't overwrite directory \"",
		    TclGetString(target), "\" with file \"",
		    TclGetString(source), "\"", NULL);
	    goto done;
	}

	/*
	 * The destination exists, but appears to be ok to over-write, and
	 * -force is given. We now try to adjust permissions to ensure the
	 * operation succeeds. If we can't adjust permissions, we'll let the
	 * actual copy/rename return an error later.
	 */

	{
	    Tcl_Obj *perm;
	    int index;

	    TclNewLiteralStringObj(perm, "u+w");
	    Tcl_IncrRefCount(perm);
	    if (TclFSFileAttrIndex(target, "-permissions", &index) == TCL_OK) {
		Tcl_FSFileAttrsSet(NULL, index, target, perm);
	    }
	    Tcl_DecrRefCount(perm);
	}
    }

    if (copyFlag == 0) {
	result = Tcl_FSRenameFile(source, target);
	if (result == TCL_OK) {
	    goto done;
	}

	if (errno == EINVAL) {
	    Tcl_AppendResult(interp, "error renaming \"",
		    TclGetString(source), "\" to \"", TclGetString(target),
		    "\": trying to rename a volume or "
		    "move a directory into itself", NULL);
	    goto done;
	} else if (errno != EXDEV) {
	    errfile = target;
	    goto done;
	}

	/*
	 * The rename failed because the move was across file systems. Fall
	 * through to copy file and then remove original. Note that the
	 * low-level Tcl_FSRenameFileProc in the filesystem is allowed to
	 * implement cross-filesystem moves itself, if it desires.
	 */
    }

    actualSource = source;
    Tcl_IncrRefCount(actualSource);

    /*
     * Activate the following block to copy files instead of links. However
     * Tcl's semantics currently say we should copy links, so any such change
     * should be the subject of careful study on the consequences.
     *
     * Perhaps there could be an optional flag to 'file copy' to dictate which
     * approach to use, with the default being _not_ to have this block
     * active.
     */

#if 0
#ifdef S_ISLNK
    if (copyFlag && S_ISLNK(sourceStatBuf.st_mode)) {
	/*
	 * We want to copy files not links. Therefore we must follow the link.
	 * There are two purposes to this 'stat' call here. First we want to
	 * know if the linked-file/dir actually exists, and second, in the
	 * block of code which follows, some 20 lines down, we want to check
	 * if the thing is a file or directory.
	 */

	if (Tcl_FSStat(source, &sourceStatBuf) != 0) {
	    /*
	     * Actual file doesn't exist.
	     */

	    Tcl_AppendResult(interp, "error copying \"", TclGetString(source),
		    "\": the target of this link doesn't exist", NULL);
	    goto done;
	} else {
	    int counter = 0;

	    while (1) {
		Tcl_Obj *path = Tcl_FSLink(actualSource, NULL, 0);
		if (path == NULL) {
		    break;
		}

		/*
		 * Now we want to check if this is a relative path, and if so,
		 * to make it absolute.
		 */

		if (Tcl_FSGetPathType(path) == TCL_PATH_RELATIVE) {
		    Tcl_Obj *abs = Tcl_FSJoinToPath(actualSource, 1, &path);

		    if (abs == NULL) {
			break;
		    }
		    Tcl_IncrRefCount(abs);
		    Tcl_DecrRefCount(path);
		    path = abs;
		}
		Tcl_DecrRefCount(actualSource);
		actualSource = path;
		counter++;

		/*
		 * Arbitrary limit of 20 links to follow.
		 */

		if (counter > 20) {
		    /*
		     * Too many links.
		     */

		    Tcl_SetErrno(EMLINK);
		    errfile = source;
		    goto done;
		}
	    }
	    /* Now 'actualSource' is the correct file */
	}
    }
#endif /* S_ISLNK */
#endif

    if (S_ISDIR(sourceStatBuf.st_mode)) {
	result = Tcl_FSCopyDirectory(actualSource, target, &errorBuffer);
	if (result != TCL_OK) {
	    if (errno == EXDEV) {
		/*
		 * The copy failed because we're trying to do a
		 * cross-filesystem copy. We do this through our Tcl library.
		 */

		Tcl_Obj *copyCommand, *cmdObj, *opObj;

		TclNewObj(copyCommand);
		TclNewLiteralStringObj(cmdObj, "::tcl::CopyDirectory");
		Tcl_ListObjAppendElement(interp, copyCommand, cmdObj);
		if (copyFlag) {
		    TclNewLiteralStringObj(opObj, "copying");
		} else {
		    TclNewLiteralStringObj(opObj, "renaming");
		}
		Tcl_ListObjAppendElement(interp, copyCommand, opObj);
		Tcl_ListObjAppendElement(interp, copyCommand, source);
		Tcl_ListObjAppendElement(interp, copyCommand, target);
		Tcl_IncrRefCount(copyCommand);
		result = Tcl_EvalObjEx(interp, copyCommand,
			TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
		Tcl_DecrRefCount(copyCommand);
		if (result != TCL_OK) {
		    /*
		     * There was an error in the Tcl-level copy. We will pass
		     * on the Tcl error message and can ensure this by setting
		     * errfile to NULL
		     */

		    errfile = NULL;
		}
	    } else {
		errfile = errorBuffer;
		if (Tcl_FSEqualPaths(errfile, source)) {
		    errfile = source;
		} else if (Tcl_FSEqualPaths(errfile, target)) {
		    errfile = target;
		}
	    }
	}
    } else {
	result = Tcl_FSCopyFile(actualSource, target);
	if ((result != TCL_OK) && (errno == EXDEV)) {
	    result = TclCrossFilesystemCopy(interp, source, target);
	}
	if (result != TCL_OK) {
	    /*
	     * We could examine 'errno' to double-check if the problem was
	     * with the target, but we checked the source above, so it should
	     * be quite clear
	     */

	    errfile = target;

	    /*
	     * We now need to reset the result, because the above call, if it
	     * failed, may have put an error message in place. (Ideally we
	     * would prefer not to pass an interpreter in above, but the
	     * channel IO code used by TclCrossFilesystemCopy currently
	     * requires one).
	     */

	    Tcl_ResetResult(interp);
	}
    }
    if ((copyFlag == 0) && (result == TCL_OK)) {
	if (S_ISDIR(sourceStatBuf.st_mode)) {
	    result = Tcl_FSRemoveDirectory(source, 1, &errorBuffer);
	    if (result != TCL_OK) {
		if (Tcl_FSEqualPaths(errfile, source) == 0) {
		    errfile = source;
		}
	    }
	} else {
	    result = Tcl_FSDeleteFile(source);
	    if (result != TCL_OK) {
		errfile = source;
	    }
	}
	if (result != TCL_OK) {
	    Tcl_AppendResult(interp, "can't unlink \"", TclGetString(errfile),
		    "\": ", Tcl_PosixError(interp), NULL);
	    errfile = NULL;
	}
    }

  done:
    if (errfile != NULL) {
	Tcl_AppendResult(interp, "error ", (copyFlag ? "copying" : "renaming"),
		 " \"", TclGetString(source), NULL);
	if (errfile != source) {
	    Tcl_AppendResult(interp, "\" to \"", TclGetString(target), NULL);
	    if (errfile != target) {
		Tcl_AppendResult(interp, "\": \"", TclGetString(errfile),NULL);
	    }
	}
	Tcl_AppendResult(interp, "\": ", Tcl_PosixError(interp), NULL);
    }
    if (errorBuffer != NULL) {
	Tcl_DecrRefCount(errorBuffer);
    }
    if (actualSource != NULL) {
	Tcl_DecrRefCount(actualSource);
    }
    return result;
}

/*
 *---------------------------------------------------------------------------
 *
 * FileForceOption --
 *
 *	Helps parse command line options for file commands that take the
 *	"-force" and "--" options.
 *
 * Results:
 *	The return value is how many arguments from argv were consumed by this
 *	function, or -1 if there was an error parsing the options. If an error
 *	occurred, an error message is left in the interp's result.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

static int
FileForceOption(
    Tcl_Interp *interp,		/* Interp, for error return. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *CONST objv[],	/* Argument strings.  First command line
				 * option, if it exists, begins at 0. */
    int *forcePtr)		/* If the "-force" was specified, *forcePtr is
				 * filled with 1, otherwise with 0. */
{
    int force, i;

    force = 0;
    for (i = 0; i < objc; i++) {
	if (TclGetString(objv[i])[0] != '-') {
	    break;
	}
	if (strcmp(TclGetString(objv[i]), "-force") == 0) {
	    force = 1;
	} else if (strcmp(TclGetString(objv[i]), "--") == 0) {
	    i++;
	    break;
	} else {
	    Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[i]),
		    "\": should be -force or --", NULL);
	    return -1;
	}
    }
    *forcePtr = force;
    return i;
}
/*
 *---------------------------------------------------------------------------
 *
 * FileBasename --
 *
 *	Given a path in either tcl format (with / separators), or in the
 *	platform-specific format for the current platform, return all the
 *	characters in the path after the last directory separator. But, if
 *	path is the root directory, returns no characters.
 *
 * Results:
 *	Returns the string object that represents the basename. If there is an
 *	error, an error message is left in interp, and NULL is returned.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

static Tcl_Obj *
FileBasename(
    Tcl_Interp *interp,		/* Interp, for error return. */
    Tcl_Obj *pathPtr)		/* Path whose basename to extract. */
{
    int objc;
    Tcl_Obj *splitPtr;
    Tcl_Obj *resultPtr = NULL;

    splitPtr = Tcl_FSSplitPath(pathPtr, &objc);
    Tcl_IncrRefCount(splitPtr);

    if (objc != 0) {
	if ((objc == 1) && (*TclGetString(pathPtr) == '~')) {
	    Tcl_DecrRefCount(splitPtr);
	    if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) {
		return NULL;
	    }
	    splitPtr = Tcl_FSSplitPath(pathPtr, &objc);
	    Tcl_IncrRefCount(splitPtr);
	}

	/*
	 * Return the last component, unless it is the only component, and it
	 * is the root of an absolute path.
	 */

	if (objc > 0) {
	    Tcl_ListObjIndex(NULL, splitPtr, objc-1, &resultPtr);
	    if ((objc == 1) &&
		    (Tcl_FSGetPathType(resultPtr) != TCL_PATH_RELATIVE)) {
		resultPtr = NULL;
	    }
	}
    }
    if (resultPtr == NULL) {
	resultPtr = Tcl_NewObj();
    }
    Tcl_IncrRefCount(resultPtr);
    Tcl_DecrRefCount(splitPtr);
    return resultPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * TclFileAttrsCmd --
 *
 *	Sets or gets the platform-specific attributes of a file. The objc-objv
 *	points to the file name with the rest of the command line following.
 *	This routine uses platform-specific tables of option strings and
 *	callbacks. The callback to get the attributes take three parameters:
 *	    Tcl_Interp *interp;	    The interp to report errors with. Since
 *				    this is an object-based API, the object
 *				    form of the result should be used.
 *	    CONST char *fileName;   This is extracted using
 *				    Tcl_TranslateFileName.
 *	    TclObj **attrObjPtrPtr; A new object to hold the attribute is
 *				    allocated and put here.
 *	The first two parameters of the callback used to write out the
 *	attributes are the same. The third parameter is:
 *	    CONST *attrObjPtr;	    A pointer to the object that has the new
 *				    attribute.
 *	They both return standard TCL errors; if the routine to get an
 *	attribute fails, no object is allocated and *attrObjPtrPtr is
 *	unchanged.
 *
 * Results:
 *	Standard TCL error.
 *
 * Side effects:
 *	May set file attributes for the file name.
 *
 *----------------------------------------------------------------------
 */

int
TclFileAttrsCmd(
    Tcl_Interp *interp,		/* The interpreter for error reporting. */
    int objc,			/* Number of command line arguments. */
    Tcl_Obj *CONST objv[])	/* The command line objects. */
{
    int result;
    CONST char ** attributeStrings;
    Tcl_Obj* objStrings = NULL;
    int numObjStrings = -1;
    Tcl_Obj *filePtr;

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 2, objv,
		"name ?option? ?value? ?option value ...?");
	return TCL_ERROR;
    }

    filePtr = objv[2];
    if (Tcl_FSConvertToPathType(interp, filePtr) != TCL_OK) {
    	return TCL_ERROR;
    }

    objc -= 3;
    objv += 3;
    result = TCL_ERROR;
    Tcl_SetErrno(0);

    attributeStrings = Tcl_FSFileAttrStrings(filePtr, &objStrings);
    if (attributeStrings == NULL) {
	int index;
	Tcl_Obj *objPtr;

	if (objStrings == NULL) {
	    if (Tcl_GetErrno() != 0) {
		/*
		 * There was an error, probably that the filePtr is not
		 * accepted by any filesystem
		 */
		Tcl_AppendResult(interp, "could not read \"",
			TclGetString(filePtr), "\": ", Tcl_PosixError(interp),
			NULL);
		return TCL_ERROR;
	    }
	    goto end;
	}

	/*
	 * We own the object now.
	 */

	Tcl_IncrRefCount(objStrings);

	/*
	 * Use objStrings as a list object.
	 */

	if (Tcl_ListObjLength(interp, objStrings, &numObjStrings) != TCL_OK) {
	    goto end;
	}
	attributeStrings = (CONST char **) TclStackAlloc(interp,
		(1+numObjStrings) * sizeof(char*));
	for (index = 0; index < numObjStrings; index++) {
	    Tcl_ListObjIndex(interp, objStrings, index, &objPtr);
	    attributeStrings[index] = TclGetString(objPtr);
	}
	attributeStrings[index] = NULL;
    }
    if (objc == 0) {
	/*
	 * Get all attributes.
	 */

	int index, res = TCL_OK, nbAtts = 0;
	Tcl_Obj *listPtr;

	listPtr = Tcl_NewListObj(0, NULL);
	for (index = 0; attributeStrings[index] != NULL; index++) {
	    Tcl_Obj *objPtrAttr;

	    if (res != TCL_OK) {
		/*
		 * Clear the error from the last iteration.
		 */

		Tcl_ResetResult(interp);
	    }

	    res = Tcl_FSFileAttrsGet(interp, index, filePtr, &objPtrAttr);
	    if (res == TCL_OK) {
		Tcl_Obj *objPtr =
			Tcl_NewStringObj(attributeStrings[index], -1);

		Tcl_ListObjAppendElement(interp, listPtr, objPtr);
		Tcl_ListObjAppendElement(interp, listPtr, objPtrAttr);
		nbAtts++;
	    }
	}

	if (index > 0 && nbAtts == 0) {
	    /*
	     * Error: no valid attributes found.
	     */

	    Tcl_DecrRefCount(listPtr);
	    goto end;
	}

    	Tcl_SetObjResult(interp, listPtr);
    } else if (objc == 1) {
	/*
	 * Get one attribute.
	 */

	int index;
	Tcl_Obj *objPtr = NULL;

	if (numObjStrings == 0) {
	    Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[0]),
		    "\", there are no file attributes in this filesystem.",
		    NULL);
	    goto end;
	}

	if (Tcl_GetIndexFromObj(interp, objv[0], attributeStrings,
		"option", 0, &index) != TCL_OK) {
	    goto end;
	}
	if (Tcl_FSFileAttrsGet(interp, index, filePtr,
		&objPtr) != TCL_OK) {
	    goto end;
	}
	Tcl_SetObjResult(interp, objPtr);
    } else {
	/*
	 * Set option/value pairs.
	 */

	int i, index;

	if (numObjStrings == 0) {
	    Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[0]),
		    "\", there are no file attributes in this filesystem.",
		    NULL);
	    goto end;
	}

    	for (i = 0; i < objc ; i += 2) {
    	    if (Tcl_GetIndexFromObj(interp, objv[i], attributeStrings,
		    "option", 0, &index) != TCL_OK) {
		goto end;
    	    }
	    if (i + 1 == objc) {
		Tcl_AppendResult(interp, "value for \"",
			TclGetString(objv[i]), "\" missing", NULL);
		goto end;
	    }
    	    if (Tcl_FSFileAttrsSet(interp, index, filePtr,
    	    	    objv[i + 1]) != TCL_OK) {
		goto end;
    	    }
    	}
    }
    result = TCL_OK;

  end:
    if (numObjStrings != -1) {
	/*
	 * Free up the array we allocated.
	 */

	TclStackFree(interp, (void *)attributeStrings);

	/*
	 * We don't need this object that was passed to us any more.
	 */

	if (objStrings != NULL) {
	    Tcl_DecrRefCount(objStrings);
	}
    }
    return result;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */
generated by cgit v0.12 at 2024-08-19 21:29:15 (GMT)