summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorvincentdarley <vincentdarley>2003-12-17 17:47:27 (GMT)
committervincentdarley <vincentdarley>2003-12-17 17:47:27 (GMT)
commit298b0c4ef39a21c71fcb823f41bb903203d8430b (patch)
tree90eee000212ab783686879d39d2836490e8198c8
parent1e34c25106c2c1a8713ef0aef0ffc4d2eccdbeeb (diff)
downloadtcl-298b0c4ef39a21c71fcb823f41bb903203d8430b.zip
tcl-298b0c4ef39a21c71fcb823f41bb903203d8430b.tar.gz
tcl-298b0c4ef39a21c71fcb823f41bb903203d8430b.tar.bz2
fix to file normalization with relative links
-rw-r--r--ChangeLog12
-rw-r--r--doc/file.n40
-rw-r--r--generic/tclCmdAH.c18
-rw-r--r--tests/fCmd.test39
-rw-r--r--tests/fileSystem.test16
-rw-r--r--unix/tclUnixFile.c58
-rw-r--r--win/tclWinFCmd.c47
7 files changed, 183 insertions, 47 deletions
diff --git a/ChangeLog b/ChangeLog
index 04e90eb..9db7bd5 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,17 @@
2003-12-17 Vince Darley <vincentdarley@users.sourceforge.net>
+ * generic/tclCmdAH.c:
+ * unix/tclUnixFile.c:
+ * win/tclWinFCmd.c:
+ * tests/fCmd.test:
+ * tests/fileSystem.test:
+ * doc/file.n: final fix to support for relative links and
+ its implications on normalization and other parts of the
+ filesystem code. Fixes [Bug 859251] and some Windows
+ problems with recursive file delete/copy and symbolic links.
+
+2003-12-17 Vince Darley <vincentdarley@users.sourceforge.net>
+
* generic/tclPathObj.c:
* tests/fileSystem.test: fix and tests for [Bug 860402] in new
file normalization code.
diff --git a/doc/file.n b/doc/file.n
index 0658009..f119a83 100644
--- a/doc/file.n
+++ b/doc/file.n
@@ -5,7 +5,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" RCS: @(#) $Id: file.n,v 1.26 2003/12/12 17:02:13 vincentdarley Exp $
+'\" RCS: @(#) $Id: file.n,v 1.27 2003/12/17 17:47:28 vincentdarley Exp $
'\"
.so man.macros
.TH file n 8.3 Tcl "Tcl Built-In Commands"
@@ -206,30 +206,34 @@ If only one argument is given, that argument is assumed to be
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
.
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 97266c0..41c9873 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCmdAH.c,v 1.37 2003/12/12 17:02:37 vincentdarley Exp $
+ * RCS: @(#) $Id: tclCmdAH.c,v 1.38 2003/12/17 17:47:28 vincentdarley Exp $
*/
#include "tclInt.h"
@@ -1071,7 +1071,19 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
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_FileObjCmd(dummy, interp, objc, objv)
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);
diff --git a/tests/fCmd.test b/tests/fCmd.test
index 71a72cf..c0f6948 100644
--- a/tests/fCmd.test
+++ b/tests/fCmd.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: fCmd.test,v 1.34 2003/12/16 15:26:44 vincentdarley Exp $
+# RCS: @(#) $Id: fCmd.test,v 1.35 2003/12/17 17:47:28 vincentdarley Exp $
#
if {[lsearch [namespace children] ::tcltest] == -1} {
@@ -2154,7 +2154,7 @@ test fCmd-26.2 {TclDeleteFilesCmd: delete dir with symlink} {unixOnly notRoot} {
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 @@ test fCmd-28.10 {file link: linking to nonexistent path} {linkDirectory} {
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 @@ test fCmd-28.15.2 {file link: copies link not dir} {linkDirectory} {
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 @@ test fCmd-28.18 {file link: glob -type d} {linkDirectory} {
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
diff --git a/tests/fileSystem.test b/tests/fileSystem.test
index 3a78665..91a468f 100644
--- a/tests/fileSystem.test
+++ b/tests/fileSystem.test
@@ -41,13 +41,17 @@ proc testPathEqual {one two} {
}
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 @@ test filesystem-1.10 {link normalisation: double link} {macOrUnix hasLinks} {
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}
diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c
index 66c31b9..96d2fda 100644
--- a/unix/tclUnixFile.c
+++ b/unix/tclUnixFile.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclUnixFile.c,v 1.35 2003/12/12 17:09:34 vincentdarley Exp $
+ * RCS: @(#) $Id: tclUnixFile.c,v 1.36 2003/12/17 17:47:28 vincentdarley Exp $
*/
#include "tclInt.h"
@@ -715,21 +715,57 @@ TclpObjLink(pathPtr, toPtr, linkAction)
{
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 @@ TclpObjLink(pathPtr, toPtr, linkAction)
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) {
diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c
index 519df62..c565d33 100644
--- a/win/tclWinFCmd.c
+++ b/win/tclWinFCmd.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclWinFCmd.c,v 1.37 2003/10/13 16:48:07 vincentdarley Exp $
+ * RCS: @(#) $Id: tclWinFCmd.c,v 1.38 2003/12/17 17:47:28 vincentdarley Exp $
*/
#include "tclWinInt.h"
@@ -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 @@ DoRemoveJustDirectory(
* 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 @@ DoRemoveJustDirectory(
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 @@ DoRemoveJustDirectory(
* 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 @@ TraverseWinTree(
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 @@ TraversalCopy(
}
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());
@@ -1406,6 +1437,12 @@ TraversalDelete(
}
break;
}
+ case DOTREE_LINK: {
+ if (DoRemoveJustDirectory(nativeSrc, 0, NULL) == TCL_OK) {
+ return TCL_OK;
+ }
+ break;
+ }
case DOTREE_PRED: {
return TCL_OK;
}