? fsfix.diff
Index: doc/file.n
===================================================================
RCS file: /cvsroot/tcl/tcl/doc/file.n,v
retrieving revision 1.26
diff -u -r1.26 file.n
--- doc/file.n	12 Dec 2003 17:02:13 -0000	1.26
+++ doc/file.n	17 Dec 2003 16:36:52 -0000
@@ -206,30 +206,34 @@
 seems to be the case with hard links, which look just like ordinary
 files), then an error is returned.
 .
-If 2 arguments are given, then these are assumed to be \fIlinkName\fR and
-\fItarget\fR. If \fIlinkName\fR already exists, or if \fItarget\fR
+If 2 arguments are given, then these are assumed to be \fIlinkName\fR
+and \fItarget\fR. If \fIlinkName\fR already exists, or if \fItarget\fR
 doesn't exist, an error will be returned.  Otherwise, Tcl creates a new
-link called \fIlinkName\fR which points to the existing filesystem object
-at \fItarget\fR, where the type of the link is platform-specific (on Unix
-a symbolic link will be the default).  This is useful for the case where
-the user wishes to create a link in a cross-platform way, and doesn't
-care what type of link is created.
+link called \fIlinkName\fR which points to the existing filesystem
+object at \fItarget\fR (which is also the returned value), where the
+type of the link is platform-specific (on Unix a symbolic link will be
+the default).  This is useful for the case where the user wishes to
+create a link in a cross-platform way, and doesn't care what type of
+link is created.
 .
 If the user wishes to make a link of a specific type only, (and signal an
 error if for some reason that is not possible), then the optional
 \fI-linktype\fR argument should be given.  Accepted values for
 \fI-linktype\fR are "-symbolic" and "-hard".
 .
-On Unix, symbolic links can be made to relative paths, but on all other
-platforms target paths will be converted to absolute, normalized form
-before the link is created (and "~user" paths are always expanded to
-absolute form).  When creating links on filesystems that
-either do not support any links, or do not support the specific type
-requested, an error message will be returned.  In particular Windows 95,
-98 and ME do not support any links at present, but most Unix platforms
-support both symbolic and hard links (the latter for files only), MacOS
-supports symbolic links and Windows NT/2000/XP (on NTFS drives) support
-symbolic directory links and hard file links.
+On Unix, symbolic links can be made to relative paths, and those paths
+must be relative to the actual \fIlinkName\fR's location (not to the
+cwd), but on all other platforms where relative links are not supported,
+target paths will always be converted to absolute, normalized form
+before the link is created (and therefore relative paths are interpreted
+as relative to the cwd).  Furthermore, "~user" paths are always expanded
+to absolute form.  When creating links on filesystems that either do not
+support any links, or do not support the specific type requested, an
+error message will be returned.  In particular Windows 95, 98 and ME do
+not support any links at present, but most Unix platforms support both
+symbolic and hard links (the latter for files only), MacOS supports
+symbolic links and Windows NT/2000/XP (on NTFS drives) support symbolic
+directory links and hard file links.
 .TP
 \fBfile lstat \fIname varName\fR
 .
Index: generic/tclCmdAH.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCmdAH.c,v
retrieving revision 1.37
diff -u -r1.37 tclCmdAH.c
--- generic/tclCmdAH.c	12 Dec 2003 17:02:37 -0000	1.37
+++ generic/tclCmdAH.c	17 Dec 2003 16:36:52 -0000
@@ -1071,7 +1071,19 @@
 				Tcl_GetString(objv[index]), 
 				"\": that path already exists", (char *) NULL);
 		    } else if (errno == ENOENT) {
-			if (Tcl_FSAccess(objv[index+1], F_OK) == 0) {
+			/*
+			 * There are two cases here: either the target
+			 * doesn't exist, or the directory of the src
+			 * doesn't exist.
+			 */
+			int access;
+			Tcl_Obj *dirPtr = TclFileDirname(interp, objv[index]);
+			if (dirPtr == NULL) {
+			    return TCL_ERROR;
+			}
+			access = Tcl_FSAccess(dirPtr, F_OK);
+			Tcl_DecrRefCount(dirPtr);
+			if (access != 0) {
 			    Tcl_AppendResult(interp, 
 			            "could not create new link \"", 
 				    Tcl_GetString(objv[index]), 
@@ -1081,7 +1093,7 @@
 			    Tcl_AppendResult(interp, 
 			            "could not create new link \"", 
 				    Tcl_GetString(objv[index]), 
-				    "\" since target \"", 
+				    "\": target \"", 
 				    Tcl_GetString(objv[index+1]), 
 				    "\" doesn't exist", 
 				    (char *) NULL);
Index: tests/fCmd.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/fCmd.test,v
retrieving revision 1.34
diff -u -r1.34 fCmd.test
--- tests/fCmd.test	16 Dec 2003 15:26:44 -0000	1.34
+++ tests/fCmd.test	17 Dec 2003 16:36:52 -0000
@@ -2154,7 +2154,7 @@
 		
     file mkdir tfad1
     file mkdir tfad2
-    file link -symbolic [file join tfad2 link] tfad1
+    file link -symbolic [file join tfad2 link] [file join .. tfad1]
     file delete -force tfad2
 
     set r1 [file isdir tfad1]
@@ -2306,7 +2306,7 @@
     set res [list [catch {file link abc.link abc2.doesnt} msg] $msg]
     cd [workingDirectory]
     set res
-} {1 {could not create new link "abc.link" since target "abc2.doesnt" doesn't exist}}
+} {1 {could not create new link "abc.link": target "abc2.doesnt" doesn't exist}}
 
 test fCmd-28.10.1 {file link: linking to nonexistent path} {linkDirectory} {
     cd [temporaryDirectory]
@@ -2388,7 +2388,10 @@
 cd [temporaryDirectory]
 file delete -force abc.link
 file delete -force abc2.link
-
+cd abc.dir
+file delete -force abc.file
+file delete -force abc2.file
+cd ..
 file copy abc.file abc.dir
 file copy abc2.file abc.dir
 cd [workingDirectory]
@@ -2416,12 +2419,40 @@
     set res
 } [lsort [list abc.link abc.dir abc2.dir]]
 
+test fCmd-28.19 {file link: relative paths} {winOnly linkDirectory} {
+    cd [temporaryDirectory]
+    file mkdir d1/d2/d3
+    set res [list [catch {file link d1/l2 d1/d2} err] $err]
+    lappend res [catch {file delete -force d1} err] $err
+} {0 d1/d2 0 {}}
+
+test fCmd-28.20 {file link: relative paths} {unixOnly linkDirectory} {
+    cd [temporaryDirectory]
+    file mkdir d1/d2/d3
+    list [catch {file link d1/l2 d1/d2} res] $res
+} {1 {could not create new link "d1/l2": target "d1/d2" doesn't exist}
+
+test fCmd-28.21 {file link: relative paths} {unixOnly linkDirectory} {
+    cd [temporaryDirectory]
+    file mkdir d1/d2/d3
+    list [catch {file link d1/l2 d2} res] $res
+} {0 d2}
+
+test fCmd-28.22 {file link: relative paths} {unixOnly linkDirectory} {
+    cd [temporaryDirectory]
+    file mkdir d1/d2/d3
+    catch {file delete -force d1/l2}
+    list [catch {file link d1/l2 d2/d3} res] $res
+} {0 d2/d3}
+
 test fCmd-29.1 {weird memory corruption fault} {
     catch {set res [open [file join ~a_totally_bogus_user_id/foo bar]]}
 } 1
 
 cd [temporaryDirectory]
 file delete -force abc.link
+file delete -force d1/d2
+file delete -force d1
 cd [workingDirectory]
 
 removeFile abc2.file
Index: tests/fileSystem.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/fileSystem.test,v
retrieving revision 1.28
diff -u -r1.28 fileSystem.test
--- tests/fileSystem.test	17 Dec 2003 10:12:04 -0000	1.28
+++ tests/fileSystem.test	17 Dec 2003 16:36:53 -0000
@@ -41,13 +41,17 @@
 }
 
 if {[catch {
-    file link link.file gorp.file 
+    file link link.file gorp.file
+    cd dir.dir
     file link \
-      [file join dir.dir linkinside.file] \
-      [file join dir.dir inside.file]
+      [file join linkinside.file] \
+      [file join inside.file]
+    cd ..
     file link dir.link dir.dir
-    file link [file join dir.dir dirinside.link] \
-      [file join dir.dir dirinside.dir]
+    cd dir.dir
+    file link [file join dirinside.link] \
+      [file join dirinside.dir]
+    cd ..
 }]} {
     tcltest::testConstraint hasLinks 0
 } else {
@@ -121,7 +125,7 @@
 makeDirectory dir2.file
 
 test filesystem-1.11 {link normalisation: double link, back in tree} {macOrUnix hasLinks} {
-    file link [file join dir2.file dir2.link] dir2.link
+    file link [file join dir2.file dir2.link] [file join .. dir2.link]
     testPathEqual [file normalize [file join dir.dir linkinside.file foo]] \
       [file normalize [file join dir2.file dir2.link inside.file foo]]
 } {1}
Index: unix/tclUnixFile.c
===================================================================
RCS file: /cvsroot/tcl/tcl/unix/tclUnixFile.c,v
retrieving revision 1.35
diff -u -r1.35 tclUnixFile.c
--- unix/tclUnixFile.c	12 Dec 2003 17:09:34 -0000	1.35
+++ unix/tclUnixFile.c	17 Dec 2003 16:36:53 -0000
@@ -715,21 +715,57 @@
 {
     if (toPtr != NULL) {
 	CONST char *src = Tcl_FSGetNativePath(pathPtr);
-	CONST char *target = Tcl_FSGetNativePath(toPtr);
+	CONST char *target = NULL;
+	if (src == NULL) return NULL;
 	
-	if (src == NULL || target == NULL) {
-	    return NULL;
+	/* 
+	 * If we're making a symbolic link and the path is relative,
+	 * then we must check whether it exists _relative_ to the
+	 * directory in which the src is found (not relative to the
+	 * current cwd which is just not relevant in this case).
+	 * 
+	 * If we're making a hard link, then a relative path is
+	 * just converted to absolute relative to the cwd.
+	 */
+	if ((linkAction & TCL_CREATE_SYMBOLIC_LINK)
+	  && (Tcl_FSGetPathType(toPtr) == TCL_PATH_RELATIVE)) {
+	    Tcl_Obj *dirPtr, *absPtr;
+	    dirPtr = TclFileDirname(NULL, pathPtr);
+	    if (dirPtr == NULL) {
+	        return NULL;
+	    }
+	    absPtr = Tcl_FSJoinToPath(dirPtr, 1, &toPtr);
+	    Tcl_IncrRefCount(absPtr);
+	    if (Tcl_FSAccess(absPtr, F_OK) == -1) {
+		Tcl_DecrRefCount(absPtr);
+		Tcl_DecrRefCount(dirPtr);
+		/* target doesn't exist */
+		errno = ENOENT;
+	        return NULL;
+	    }
+	    /* 
+	     * Target exists; we'll construct the relative
+	     * path we want below.
+	     */
+	    Tcl_DecrRefCount(absPtr);
+	    Tcl_DecrRefCount(dirPtr);
+	} else {
+	    target = Tcl_FSGetNativePath(toPtr);
+	    if (access(target, F_OK) == -1) {
+		/* target doesn't exist */
+		errno = ENOENT;
+		return NULL;
+	    }
+	    if (target == NULL) {
+		return NULL;
+	    }
 	}
+	
 	if (access(src, F_OK) != -1) {
 	    /* src exists */
 	    errno = EEXIST;
 	    return NULL;
 	}
-	if (access(target, F_OK) == -1) {
-	    /* target doesn't exist */
-	    errno = ENOENT;
-	    return NULL;
-	}
 	/* 
 	 * Check symbolic link flag first, since we prefer to
 	 * create these.
@@ -740,8 +776,8 @@
 	    Tcl_Obj *transPtr;
 	    /* 
 	     * Now we don't want to link to the absolute, normalized path.
-	     * Relative links are quite acceptable, as are links to '~user',
-	     * for example.
+	     * Relative links are quite acceptable (but links to ~user
+	     * are not -- these must be expanded first).
 	     */
 	    transPtr = Tcl_FSGetTranslatedPath(NULL, toPtr);
 	    if (transPtr == NULL) {
Index: win/tclWinFCmd.c
===================================================================
RCS file: /cvsroot/tcl/tcl/win/tclWinFCmd.c,v
retrieving revision 1.37
diff -u -r1.37 tclWinFCmd.c
--- win/tclWinFCmd.c	13 Oct 2003 16:48:07 -0000	1.37
+++ win/tclWinFCmd.c	17 Dec 2003 16:36:53 -0000
@@ -22,6 +22,7 @@
 #define DOTREE_PRED   1     /* pre-order directory  */
 #define DOTREE_POSTD  2     /* post-order directory */
 #define DOTREE_F      3     /* regular file */
+#define DOTREE_LINK   4     /* symbolic link */
 
 /*
  * Callbacks for file attributes code.
@@ -969,6 +970,7 @@
 				 * DString filled with UTF-8 name of file
 				 * causing error. */
 {
+    DWORD attr;
     /*
      * The RemoveDirectory API acts differently under Win95/98 and NT
      * WRT NULL and "". Avoid passing these values.
@@ -979,13 +981,24 @@
 	goto end;
     }
 
-    if ((*tclWinProcs->removeDirectoryProc)(nativePath) != FALSE) {
-	return TCL_OK;
+    attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
+
+    if (attr & FILE_ATTRIBUTE_REPARSE_POINT) {
+	/* It is a symbolic link -- remove it */
+	if (TclWinSymLinkDelete(nativePath, 0) == 0) {
+	    return TCL_OK;
+	}
+    } else {
+	/* Ordinary directory */
+	if ((*tclWinProcs->removeDirectoryProc)(nativePath) != FALSE) {
+	    return TCL_OK;
+	}
     }
+    
     TclWinConvertError(GetLastError());
 
     if (Tcl_GetErrno() == EACCES) {
-	DWORD attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
+	attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
 	if (attr != 0xffffffff) {
 	    if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
 		/* 
@@ -1021,6 +1034,7 @@
 	     * Windows 95 and Win32s report removing a non-empty directory 
 	     * as EACCES, not EEXIST.  If the directory is not empty,
 	     * change errno so caller knows what's going on.
+
 	     */
 
 	    if (TclWinGetPlatformId() != VER_PLATFORM_WIN32_NT) {
@@ -1166,6 +1180,16 @@
 	nativeErrfile = nativeSource;
 	goto end;
     }
+    
+    if (sourceAttr & FILE_ATTRIBUTE_REPARSE_POINT) {
+	/*
+	 * Process the symbolic link
+	 */
+
+	return (*traverseProc)(nativeSource, nativeTarget, 
+			       DOTREE_LINK, errorPtr);
+    }
+    
     if ((sourceAttr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
 	/*
 	 * Process the regular file
@@ -1344,10 +1368,17 @@
 	    }
 	    break;
 	}
+	case DOTREE_LINK: {
+	    if (TclWinSymLinkCopyDirectory(nativeSrc, nativeDst) == TCL_OK) {
+		return TCL_OK;
+	    }
+	    break;
+	}
 	case DOTREE_PRED: {
 	    if (DoCreateDirectory(nativeDst) == TCL_OK) {
 		DWORD attr = (*tclWinProcs->getFileAttributesProc)(nativeSrc);
-		if ((*tclWinProcs->setFileAttributesProc)(nativeDst, attr) != FALSE) {
+		if ((*tclWinProcs->setFileAttributesProc)(nativeDst, attr) 
+		  != FALSE) {
 		    return TCL_OK;
 		}
 		TclWinConvertError(GetLastError());
@@ -1402,6 +1433,12 @@
     switch (type) {
 	case DOTREE_F: {
 	    if (TclpDeleteFile(nativeSrc) == TCL_OK) {
+		return TCL_OK;
+	    }
+	    break;
+	}
+	case DOTREE_LINK: {
+	    if (DoRemoveJustDirectory(nativeSrc, 0, NULL) == TCL_OK) {
 		return TCL_OK;
 	    }
 	    break;
