Attachment "fsfix.diff" to
ticket [859251ffff]
added by
vincentdarley
2003-12-17 23:40:07.
? 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;
