Attachment "tip99.patch" to
ticket [562970ffff]
added by
vincentdarley
2002-06-18 17:32:37.
? tests/outdata
? tests/test1
? tests/test3
? tests/_tcl_test_remove_me.txt
? win/outdata
Index: doc/FileSystem.3
===================================================================
RCS file: /cvsroot/tcl/tcl/doc/FileSystem.3,v
retrieving revision 1.25
diff -b -u -r1.25 FileSystem.3
--- doc/FileSystem.3 13 Jun 2002 09:39:59 -0000 1.25
+++ doc/FileSystem.3 18 Jun 2002 10:23:19 -0000
@@ -64,7 +64,7 @@
\fBTcl_FSMatchInDirectory\fR(\fIinterp, result, pathPtr, pattern, types\fR)
.sp
Tcl_Obj*
-\fBTcl_FSLink\fR(\fIpathPtr, toPtr, linkType\fR)
+\fBTcl_FSLink\fR(\fIpathPtr, toPtr, linkAction\fR)
.sp
int
\fBTcl_FSLstat\fR(\fIpathPtr, statPtr\fR)
@@ -343,18 +343,22 @@
will call this function frequently asking only for directories to be
returned.
.PP
-\fBTcl_FSLink\fR replaces the library version of readlink(), and may
-also be used in the future to allow link creation.
-The appropriate function for the filesystem to which pathPtr
-belongs will be called.
-.PP
-If the \fItoPtr\fR is NULL, a readlink action is performed.
-The result is a Tcl_Obj specifying the contents of the symbolic link
-given by \fIpath\fR, or NULL if the symbolic link could not be read. The
-result is owned by the caller, which should call Tcl_DecrRefCount when
-the result is no longer needed. If the \fItoPtr\fR is not NULL, Tcl
-should create a link, but this option is not currently supported (it
-and the \fIlinkType\fR field are left available for future expansion).
+\fBTcl_FSLink\fR replaces the library version of readlink(), and supports
+the creation of links. The appropriate function for the filesystem to
+which pathPtr belongs will be called.
+.PP
+If the \fItoPtr\fR is NULL, a readlink action is performed. The result
+is a Tcl_Obj specifying the contents of the symbolic link given by
+\fIpath\fR, or NULL if the link could not be read. The result is owned
+by the caller, which should call Tcl_DecrRefCount when the result is no
+longer needed. If the \fItoPtr\fR is not NULL, Tcl should create a link
+of one of the types passed in in the \fIlinkAction\fR flag. This flag is
+an or'd combination of TCL_CREATE_SYMBOLIC_LINK and TCL_CREATE_HARD_LINK.
+Where a choice exists (i.e. more than one flag is passed in), the Tcl
+convention is to prefer symbolic links. When a link is successfully
+created, the return value should be \fItoPtr\fR (which is therefore
+already owned by the caller). If unsuccessful, NULL should be
+returned.
.PP
\fBTcl_FSLstat\fR fills the stat structure \fIstatPtr\fR with information
about the specified file. You do not need any access rights to the
@@ -1032,7 +1036,7 @@
typedef Tcl_Obj* Tcl_FSLinkProc(
Tcl_Obj *\fIpathPtr\fR,
Tcl_Obj *\fItoPtr\fR,
- int \fIlinkType\fR);
+ int \fIlinkAction\fR);
.CE
.PP
If \fItoPtr\fR is NULL, the function is being asked to read the
Index: doc/file.n
===================================================================
RCS file: /cvsroot/tcl/tcl/doc/file.n,v
retrieving revision 1.18
diff -b -u -r1.18 file.n
--- doc/file.n 8 May 2002 23:48:23 -0000 1.18
+++ doc/file.n 18 Jun 2002 10:23:19 -0000
@@ -191,6 +191,37 @@
Windows, and \fB:\fR for Macintosh.
.RE
.TP
+\fBfile link ?\fI-linktype\fR? \fIlinkName\fR ?\fItarget\fR?
+.
+If only one argument is given, that argument is assumed to be
+\fIlinkName\fR, and this command returns the value of the link given by
+\fIlinkName\fR (i.e. the name of the file it points to). If
+\fIlinkName\fR isn't a link or its value cannot be read (as, for example,
+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
+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.
+.
+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".
+.
+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
.
Same as \fBstat\fR option (see below) except uses the \fIlstat\fR
Index: generic/tcl.decls
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tcl.decls,v
retrieving revision 1.89
diff -b -u -r1.89 tcl.decls
--- generic/tcl.decls 13 Jun 2002 09:39:59 -0000 1.89
+++ generic/tcl.decls 18 Jun 2002 10:23:22 -0000
@@ -1577,7 +1577,7 @@
Tcl_Obj *pathPtr, CONST char *pattern, Tcl_GlobTypeData *types)
}
declare 446 generic {
- Tcl_Obj * Tcl_FSLink(Tcl_Obj *pathPtr, Tcl_Obj *toPtr, int linkType)
+ Tcl_Obj * Tcl_FSLink(Tcl_Obj *pathPtr, Tcl_Obj *toPtr, int linkAction)
}
declare 447 generic {
int Tcl_FSRemoveDirectory(Tcl_Obj *pathPtr,
Index: generic/tcl.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tcl.h,v
retrieving revision 1.128
diff -b -u -r1.128 tcl.h
--- generic/tcl.h 18 Jun 2002 00:12:44 -0000 1.128
+++ generic/tcl.h 18 Jun 2002 10:23:23 -0000
@@ -1840,6 +1840,17 @@
*/
} Tcl_Filesystem;
+/*
+ * The following definitions are used as values for the 'linkAction' flag
+ * to Tcl_FSLink, or the linkProc of any filesystem. Any combination
+ * of flags can be given. For link creation, the linkProc should create
+ * a link which matches any of the types given.
+ *
+ * TCL_CREATE_SYMBOLIC_LINK: Create a symbolic or soft link.
+ * TCL_CREATE_HARD_LINK: Create a hard link.
+ */
+#define TCL_CREATE_SYMBOLIC_LINK 0x01
+#define TCL_CREATE_HARD_LINK 0x02
/*
* The following structure represents the Notifier functions that
Index: generic/tclCmdAH.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCmdAH.c,v
retrieving revision 1.25
diff -b -u -r1.25 tclCmdAH.c
--- generic/tclCmdAH.c 13 Jun 2002 09:40:00 -0000 1.25
+++ generic/tclCmdAH.c 18 Jun 2002 10:23:24 -0000
@@ -791,8 +791,8 @@
"atime", "attributes", "channels", "copy",
"delete",
"dirname", "executable", "exists", "extension",
- "isdirectory", "isfile", "join", "lstat",
- "mtime", "mkdir", "nativename",
+ "isdirectory", "isfile", "join", "link",
+ "lstat", "mtime", "mkdir", "nativename",
"normalize", "owned",
"pathtype", "readable", "readlink", "rename",
"rootname", "separator", "size", "split",
@@ -804,8 +804,8 @@
FILE_ATIME, FILE_ATTRIBUTES, FILE_CHANNELS, FILE_COPY,
FILE_DELETE,
FILE_DIRNAME, FILE_EXECUTABLE, FILE_EXISTS, FILE_EXTENSION,
- FILE_ISDIRECTORY, FILE_ISFILE, FILE_JOIN, FILE_LSTAT,
- FILE_MTIME, FILE_MKDIR, FILE_NATIVENAME,
+ FILE_ISDIRECTORY, FILE_ISFILE, FILE_JOIN, FILE_LINK,
+ FILE_LSTAT, FILE_MTIME, FILE_MKDIR, FILE_NATIVENAME,
FILE_NORMALIZE, FILE_OWNED,
FILE_PATHTYPE, FILE_READABLE, FILE_READLINK, FILE_RENAME,
FILE_ROOTNAME, FILE_SEPARATOR, FILE_SIZE, FILE_SPLIT,
@@ -953,6 +953,76 @@
}
resObj = Tcl_FSJoinToPath(NULL, objc - 2, objv + 2);
Tcl_SetObjResult(interp, resObj);
+ return TCL_OK;
+ }
+ case FILE_LINK: {
+ Tcl_Obj *contents;
+ int index;
+
+ if (objc < 3 || objc > 5) {
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "?-linktype? source ?target?");
+ return TCL_ERROR;
+ }
+
+ /* Index of the 'source' argument */
+ if (objc == 5) {
+ index = 3;
+ } else {
+ index = 2;
+ }
+
+ if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ if (objc > 3) {
+ int linkAction;
+ if (objc == 5) {
+ /* We have a '-linktype' argument */
+ static CONST char *linkTypes[] = {
+ "-symbolic", "-hard", NULL
+ };
+ if (Tcl_GetIndexFromObj(interp, objv[2], linkTypes,
+ "switch", 0, &linkAction) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (linkAction == 0) {
+ linkAction = TCL_CREATE_SYMBOLIC_LINK;
+ } else {
+ linkAction = TCL_CREATE_HARD_LINK;
+ }
+ } else {
+ linkAction = TCL_CREATE_SYMBOLIC_LINK|TCL_CREATE_HARD_LINK;
+ }
+ /* Create link from source to target */
+ contents = Tcl_FSLink(objv[index], objv[index+1], linkAction);
+ if (contents == NULL) {
+ Tcl_AppendResult(interp, "could not create link from \"",
+ Tcl_GetString(objv[index]), "\" to \"",
+ Tcl_GetString(objv[index+1]), "\": ",
+ Tcl_PosixError(interp), (char *) NULL);
+ return TCL_ERROR;
+ }
+ } else {
+ /* Read link */
+ contents = Tcl_FSLink(objv[index], NULL, 0);
+ if (contents == NULL) {
+ Tcl_AppendResult(interp, "could not read link \"",
+ Tcl_GetString(objv[index]), "\": ",
+ Tcl_PosixError(interp), (char *) NULL);
+ return TCL_ERROR;
+ }
+ }
+ Tcl_SetObjResult(interp, contents);
+ if (objc == 3) {
+ /*
+ * If we are reading a link, we need to free this
+ * result refCount. If we are creating a link, this
+ * will just be objv[index+1], and so we don't own it.
+ */
+ Tcl_DecrRefCount(contents);
+ }
return TCL_OK;
}
case FILE_LSTAT: {
Index: generic/tclIOUtil.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclIOUtil.c,v
retrieving revision 1.49
diff -b -u -r1.49 tclIOUtil.c
--- generic/tclIOUtil.c 13 Jun 2002 09:40:00 -0000 1.49
+++ generic/tclIOUtil.c 18 Jun 2002 10:23:31 -0000
@@ -2690,34 +2690,37 @@
* the caller, which should call Tcl_DecrRefCount when the result
* is no longer needed.
*
- * If toPtr is non-NULL, then the result is toPtr if the link
+ * If toPtr is non-NULL, then the result is toPtr if the link action
* was successful, or NULL if not. In this case the result has no
- * additional reference count, and need not be freed.
+ * additional reference count, and need not be freed. The actual
+ * action to perform is given by the 'linkAction' flags, which is
+ * an or'd combination of:
+ *
+ * TCL_CREATE_SYMBOLIC_LINK
+ * TCL_CREATE_HARD_LINK
*
* Note that most filesystems will not support linking across
* to different filesystems, so this function will usually
* fail unless toPtr is in the same FS as pathPtr.
*
- * Note: currently no Tcl filesystems support the 'link' action,
- * so we actually always return an error for that call.
- *
* Side effects:
- * See readlink() documentation.
+ * See readlink() documentation. A new filesystem link
+ * object may appear
*
*---------------------------------------------------------------------------
*/
Tcl_Obj *
-Tcl_FSLink(pathPtr, toPtr, linkType)
+Tcl_FSLink(pathPtr, toPtr, linkAction)
Tcl_Obj *pathPtr; /* Path of file to readlink or link */
Tcl_Obj *toPtr; /* NULL or path to be linked to */
- int linkType; /* Type of link to create */
+ int linkAction; /* Action to perform */
{
Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSLinkProc *proc = fsPtr->linkProc;
if (proc != NULL) {
- return (*proc)(pathPtr, toPtr, linkType);
+ return (*proc)(pathPtr, toPtr, linkAction);
}
}
/*
Index: generic/tclTest.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclTest.c,v
retrieving revision 1.50
diff -b -u -r1.50 tclTest.c
--- generic/tclTest.c 13 Jun 2002 09:40:00 -0000 1.50
+++ generic/tclTest.c 18 Jun 2002 10:23:35 -0000
@@ -2007,7 +2007,8 @@
if (objc == 3) {
/* Create link from source to target */
- contents = Tcl_FSLink(objv[1], objv[2], 0);
+ contents = Tcl_FSLink(objv[1], objv[2],
+ TCL_CREATE_SYMBOLIC_LINK|TCL_CREATE_HARD_LINK);
if (contents == NULL) {
Tcl_AppendResult(interp, "could not create link from \"",
Tcl_GetString(objv[1]), "\" to \"",
Index: mac/tclMacFile.c
===================================================================
RCS file: /cvsroot/tcl/tcl/mac/tclMacFile.c,v
retrieving revision 1.22
diff -b -u -r1.22 tclMacFile.c
--- mac/tclMacFile.c 13 Jun 2002 09:40:00 -0000 1.22
+++ mac/tclMacFile.c 18 Jun 2002 10:23:37 -0000
@@ -1145,15 +1145,21 @@
#ifdef S_IFLNK
Tcl_Obj*
-TclpObjLink(pathPtr, toPtr, linkType)
+TclpObjLink(pathPtr, toPtr, linkAction)
Tcl_Obj *pathPtr;
Tcl_Obj *toPtr;
- int linkType;
+ int linkAction;
{
Tcl_Obj* link = NULL;
if (toPtr != NULL) {
+ if (linkAction & TCL_CREATE_SYMBOLIC_LINK) {
+ /* Needs to create a link */
return NULL;
+ } else {
+ errno = ENODEV;
+ return NULL;
+ }
} else {
Tcl_DString ds;
Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
Index: tests/cmdAH.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/cmdAH.test,v
retrieving revision 1.20
diff -b -u -r1.20 cmdAH.test
--- tests/cmdAH.test 7 May 2002 18:03:04 -0000 1.20
+++ tests/cmdAH.test 18 Jun 2002 10:23:45 -0000
@@ -168,7 +168,7 @@
} {1 {wrong # args: should be "file option ?arg ...?"}}
test cmdAH-5.2 {Tcl_FileObjCmd} {
list [catch {file x} msg] $msg
-} {1 {bad option "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
+} {1 {bad option "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-5.3 {Tcl_FileObjCmd} {
list [catch {file exists} msg] $msg
} {1 {wrong # args: should be "file exists name"}}
@@ -1220,7 +1220,7 @@
# lstat and readlink: don't run these tests everywhere, since not all
# sites will have symbolic links
-catch {exec ln -s gorp.file link.file}
+catch {file link -symbolic link.file gorp.file}
test cmdAH-23.1 {Tcl_FileObjCmd: lstat} {
list [catch {file lstat a} msg] $msg
} {1 {wrong # args: should be "file lstat name varName"}}
@@ -1517,6 +1517,14 @@
file delete link.file
set result
} link
+test cmdAH-29.4.1 {Tcl_FileObjCmd: type} {
+ file mkdir temp
+ file link -symbolic link.dir temp
+ set result [file type link.dir]
+ file delete link.dir
+ file delete temp
+ set result
+} link
test cmdAH-29.5 {Tcl_FileObjCmd: type} {
string tolower [list [catch {file type _bogus_} msg] $msg $errorCode]
} {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}
@@ -1525,25 +1533,25 @@
test cmdAH-30.1 {Tcl_FileObjCmd: error conditions} {
list [catch {file gorp x} msg] $msg
-} {1 {bad option "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
+} {1 {bad option "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-30.2 {Tcl_FileObjCmd: error conditions} {
list [catch {file ex x} msg] $msg
-} {1 {ambiguous option "ex": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
+} {1 {ambiguous option "ex": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-30.3 {Tcl_FileObjCmd: error conditions} {
list [catch {file is x} msg] $msg
-} {1 {ambiguous option "is": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
+} {1 {ambiguous option "is": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-30.4 {Tcl_FileObjCmd: error conditions} {
list [catch {file z x} msg] $msg
-} {1 {bad option "z": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
+} {1 {bad option "z": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-30.5 {Tcl_FileObjCmd: error conditions} {
list [catch {file read x} msg] $msg
-} {1 {ambiguous option "read": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
+} {1 {ambiguous option "read": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-30.6 {Tcl_FileObjCmd: error conditions} {
list [catch {file s x} msg] $msg
-} {1 {ambiguous option "s": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
+} {1 {ambiguous option "s": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-30.7 {Tcl_FileObjCmd: error conditions} {
list [catch {file t x} msg] $msg
-} {1 {ambiguous option "t": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
+} {1 {ambiguous option "t": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-30.8 {Tcl_FileObjCmd: error conditions} {
list [catch {file dirname ~woohgy} msg] $msg
} {1 {user "woohgy" doesn't exist}}
Index: tests/fCmd.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/fCmd.test,v
retrieving revision 1.13
diff -b -u -r1.13 fCmd.test
--- tests/fCmd.test 13 Jun 2002 13:17:06 -0000 1.13
+++ tests/fCmd.test 18 Jun 2002 10:23:47 -0000
@@ -2186,13 +2186,21 @@
tcltest::testConstraint linkFile 0
}
-test fCmd-28.1 {testfilelink} {testfilelink} {
- list [catch {testfilelink} msg] $msg
-} {1 {wrong # args: should be "testfilelink source ?target?"}}
-
-test fCmd-28.2 {testfilelink} {testfilelink} {
- list [catch {testfilelink a b c d} msg] $msg
-} {1 {wrong # args: should be "testfilelink source ?target?"}}
+test fCmd-28.1 {file link} {testfilelink} {
+ list [catch {file link} msg] $msg
+} {1 {wrong # args: should be "file link ?-linktype? source ?target?"}}
+
+test fCmd-28.2 {file link} {testfilelink} {
+ list [catch {file link a b c d} msg] $msg
+} {1 {wrong # args: should be "file link ?-linktype? source ?target?"}}
+
+test fCmd-28.3 {file link} {testfilelink} {
+ list [catch {file link abc b c} msg] $msg
+} {1 {bad switch "abc": must be -symbolic or -hard}}
+
+test fCmd-28.4 {file link} {testfilelink} {
+ list [catch {file link -abc b c} msg] $msg
+} {1 {bad switch "-abc": must be -symbolic or -hard}}
catch {file delete -force abc.dir}
catch {file delete -force abc2.dir}
@@ -2201,46 +2209,74 @@
makeFile contents abc.file
makeFile contents abc2.file
-test fCmd-28.3 {testfilelink} {linkDirectory winOnly} {
- list [catch {testfilelink abc.dir abc2.dir} msg] $msg
+test fCmd-28.5 {file link: source already exists} {linkDirectory} {
+ list [catch {file link abc.dir abc2.dir} msg] $msg
} {1 {could not create link from "abc.dir" to "abc2.dir": file already exists}}
-test fCmd-28.4 {testfilelink} {linkFile winOnly} {
- list [catch {testfilelink abc.file abc2.file} msg] $msg
+test fCmd-28.6 {file link: unsupported operation} {linkDirectory macOrWin} {
+ list [catch {file link -hard abc.link abc.dir} msg] $msg
+} {1 {could not create link from "abc.link" to "abc.dir": illegal operation on a directory}}
+
+test fCmd-28.7 {file link: source already exists} {linkFile} {
+ list [catch {file link abc.file abc2.file} msg] $msg
} {1 {could not create link from "abc.file" to "abc2.file": file already exists}}
-test fCmd-28.5 {testfilelink} {linkFile winOnly} {
+test fCmd-28.8 {file link} {linkFile winOnly} {
+ list [catch {file link -symbolic abc.link abc.file} msg] $msg
+} {1 {could not create link from "abc.link" to "abc.file": not a directory}}
+
+test fCmd-28.9 {file link: success with file} {linkFile} {
file delete -force abc.link
- list [catch {testfilelink abc.link abc.file} msg] $msg
+ list [catch {file link abc.link abc.file} msg] $msg
} {0 abc.file}
catch {file delete -force abc.link}
-test fCmd-28.6 {testfilelink} {linkDirectory winOnly} {
+test fCmd-28.10 {file link: linking to nonexistent path} {linkDirectory} {
file delete -force abc.link
- list [catch {testfilelink abc.link abc2.doesnt} msg] $msg
+ list [catch {file link abc.link abc2.doesnt} msg] $msg
} {1 {could not create link from "abc.link" to "abc2.doesnt": no such file or directory}}
-test fCmd-28.7 {testfilelink} {linkDirectory winOnly} {
+test fCmd-28.11 {file link: success with directory} {linkDirectory} {
file delete -force abc.link
- list [catch {testfilelink abc.link abc.dir} msg] $msg
+ list [catch {file link abc.link abc.dir} msg] $msg
} {0 abc.dir}
-test fCmd-28.7.1 {testfilelink} {linkDirectory winOnly} {
+test fCmd-28.12 {file link: cd into a link} {linkDirectory} {
+ file delete -force abc.link
+ file link abc.link abc.dir
+ set orig [pwd]
+ cd abc.link
+ set dir [pwd]
+ cd ..
+ set up [pwd]
+ cd $orig
+ # now '$up' should be either $orig or [file dirname abc.dir]
+ # (on windows the former, on unix the latter, I believe)
+ if {([file normalize $up] != [file normalize $orig]) \
+ && ([file normalize $up] != [file normalize [file dirname abc.dir]])} {
+ set res "wrong directory with 'cd $link ; cd ..'"
+ } else {
+ set res "ok"
+ }
+ set res
+} {ok}
+
+test fCmd-28.13 {file link} {linkDirectory} {
# duplicate link throws error
- list [catch {testfilelink abc.link abc.dir} msg] $msg
+ list [catch {file link abc.link abc.dir} msg] $msg
} {1 {could not create link from "abc.link" to "abc.dir": file already exists}}
-test fCmd-28.8 {testfilelink: deletes link not dir} {linkDirectory winOnly} {
+test fCmd-28.14 {file link: deletes link not dir} {linkDirectory} {
file delete -force abc.link
list [file exists abc.link] [file exists abc.dir]
} {0 1}
-test fCmd-28.9 {testfilelink: copies link not dir} {linkDirectory winOnly} {
+test fCmd-28.15 {file link: copies link not dir} {linkDirectory} {
file delete -force abc.link
- testfilelink abc.link abc.dir
+ file link abc.link abc.dir
file copy abc.link abc2.link
- list [file type abc2.link] [file tail [testfilelink abc2.link]]
+ list [file type abc2.link] [file tail [file link abc2.link]]
} {link abc.dir}
file delete -force abc.link
@@ -2249,17 +2285,17 @@
file copy abc.file abc.dir
file copy abc2.file abc.dir
-test fCmd-28.10 {testfilelink: glob inside link} {linkDirectory winOnly} {
+test fCmd-28.16 {file link: glob inside link} {linkDirectory} {
file delete -force abc.link
- testfilelink abc.link abc.dir
+ file link abc.link abc.dir
glob -dir abc.link -tails *
} {abc.file abc2.file}
-test fCmd-28.11 {testfilelink: glob -type l} {linkDirectory winOnly} {
+test fCmd-28.17 {file link: glob -type l} {linkDirectory} {
glob -dir [pwd] -type l -tails abc*
} {abc.link}
-test fCmd-28.12 {testfilelink: glob -type d} {linkDirectory winOnly} {
+test fCmd-28.18 {file link: glob -type d} {linkDirectory} {
lsort [glob -dir [pwd] -type d -tails abc*]
} [lsort [list abc.link abc.dir abc2.dir]]
Index: tests/fileName.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/fileName.test,v
retrieving revision 1.22
diff -b -u -r1.22 fileName.test
--- tests/fileName.test 30 May 2002 09:27:11 -0000 1.22
+++ tests/fileName.test 18 Jun 2002 10:23:48 -0000
@@ -1172,12 +1172,12 @@
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]]
-test filename-11.17.2 {Tcl_GlobCmd} {unixOnly notRoot} {
+test filename-11.17.2 {Tcl_GlobCmd} {notRoot} {
set dir [pwd]
set ret "error in test"
if {[catch {
cd $globname
- exec ln -s a1 link
+ file link -symbolic link a1
cd $dir
set ret [list [catch {
lsort [glob -directory $globname -join * b1]
@@ -1190,12 +1190,12 @@
} [list 0 [lsort [list [file join $globname a1 b1] \
[file join $globname link b1]]]]
# Simpler version of the above test to illustrate a given bug.
-test filename-11.17.3 {Tcl_GlobCmd} {unixOnly notRoot} {
+test filename-11.17.3 {Tcl_GlobCmd} {notRoot} {
set dir [pwd]
set ret "error in test"
if {[catch {
cd $globname
- exec ln -s a1 link
+ file link -symbolic link a1
cd $dir
set ret [list [catch {
lsort [glob -directory $globname -type d *]
@@ -1211,12 +1211,12 @@
[file join $globname link]]]]
# Make sure the bugfix isn't too simple. We don't want
# to break 'glob -type l'.
-test filename-11.17.4 {Tcl_GlobCmd} {unixOnly notRoot} {
+test filename-11.17.4 {Tcl_GlobCmd} {notRoot} {
set dir [pwd]
set ret "error in test"
if {[catch {
cd $globname
- exec ln -s a1 link
+ file link -symbolic link a1
cd $dir
set ret [list [catch {
lsort [glob -directory $globname -type l *]
Index: tests/fileSystem.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/fileSystem.test,v
retrieving revision 1.9
diff -b -u -r1.9 fileSystem.test
--- tests/fileSystem.test 13 Jun 2002 09:40:00 -0000 1.9
+++ tests/fileSystem.test 18 Jun 2002 10:23:48 -0000
@@ -32,11 +32,11 @@
makeFile "test file in directory" [file join dir.file inside.file]
if {[catch {
- testfilelink link.file gorp.file
- testfilelink \
+ file link link.file gorp.file
+ file link \
[file join dir.file linkinside.file] \
[file join dir.file inside.file]
- testfilelink dir.link dir.file
+ file link dir.link dir.file
}]} {
tcltest::testConstraint links 0
} else {
@@ -86,6 +86,49 @@
[file normalize [file join dir.link inside.filefoo]]
} {0}
+test filesystem-1.9 {link normalisation} {links} {
+ file delete -force dir.link
+ file link dir.link [file nativename dir.file]
+ string equal [file normalize [file join dir.file linkinside.file foo]] \
+ [file normalize [file join dir.link inside.file foo]]
+} {0}
+
+test filesystem-1.10 {link normalisation: double link} {links} {
+ file link dir2.link dir.link
+ string equal [file normalize [file join dir.file linkinside.file foo]] \
+ [file normalize [file join dir2.link inside.file foo]]
+} {0}
+
+makeDirectory dir2.file
+
+test filesystem-1.11 {link normalisation: double link, back in tree} {links} {
+ file link [file join dir2.file dir2.link] dir2.link
+ string equal [file normalize [file join dir.file linkinside.file foo]] \
+ [file normalize [file join dir2.file dir2.link inside.file foo]]
+} {0}
+
+test filesystem-1.12 {file new native path} {} {
+ for {set i 0} {$i < 10} {incr i} {
+ foreach f [lsort [glob -nocomplain -type l *]] {
+ catch {file readlink $f}
+ }
+ }
+ # If we reach here we've succeeded. We used to crash above.
+ expr 1
+} {1}
+
+test filesystem-1.13 {file normalisation} {winOnly} {
+ # This used to be broken
+ file normalize C:/thislongnamedoesntexist
+} {C:/thislongnamedoesntexist}
+
+test filesystem-1.14 {file normalisation} {winOnly} {
+ # This used to be broken
+ file normalize c:/
+} {C:/}
+
+file delete -force dir2.file
+file delete -force dir2.link
file delete -force link.file dir.link
removeFile [file join dir.file inside.file]
removeDirectory dir.file
Index: unix/tclUnixFile.c
===================================================================
RCS file: /cvsroot/tcl/tcl/unix/tclUnixFile.c,v
retrieving revision 1.23
diff -b -u -r1.23 tclUnixFile.c
--- unix/tclUnixFile.c 13 Jun 2002 09:40:01 -0000 1.23
+++ unix/tclUnixFile.c 18 Jun 2002 10:23:49 -0000
@@ -724,10 +724,10 @@
#ifdef S_IFLNK
Tcl_Obj*
-TclpObjLink(pathPtr, toPtr, linkType)
+TclpObjLink(pathPtr, toPtr, linkAction)
Tcl_Obj *pathPtr;
Tcl_Obj *toPtr;
- int linkType;
+ int linkAction;
{
extern Tcl_Filesystem nativeFilesystem;
@@ -738,12 +738,27 @@
if (src == NULL || target == NULL) {
return NULL;
}
- /* We don't recognise these codes */
- if (linkType < 0 || linkType > 2) return NULL;
- if (linkType == 2) {
- if (link(src, target) != 0) 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.
+ */
+ if (linkAction & TCL_CREATE_SYMBOLIC_LINK) {
+ if (symlink(target, src) != 0) return NULL;
+ } else if (linkAction & TCL_CREATE_HARD_LINK) {
+ if (link(target, src) != 0) return NULL;
} else {
- if (symlink(src, target) != 0) return NULL;
+ errno = ENODEV;
+ return NULL;
}
return toPtr;
} else {
Index: win/tclWinFile.c
===================================================================
RCS file: /cvsroot/tcl/tcl/win/tclWinFile.c,v
retrieving revision 1.32
diff -b -u -r1.32 tclWinFile.c
--- win/tclWinFile.c 13 Jun 2002 10:43:41 -0000 1.32
+++ win/tclWinFile.c 18 Jun 2002 10:23:51 -0000
@@ -162,7 +162,7 @@
static Tcl_Obj* WinReadLink(CONST TCHAR* LinkSource);
static Tcl_Obj* WinReadLinkDirectory(CONST TCHAR* LinkDirectory);
static int WinLink(CONST TCHAR* LinkSource, CONST TCHAR* LinkTarget,
- int linkType);
+ int linkAction);
static int WinSymLinkDirectory(CONST TCHAR* LinkDirectory,
CONST TCHAR* LinkTarget);
extern Tcl_Filesystem nativeFilesystem;
@@ -177,10 +177,10 @@
*--------------------------------------------------------------------
*/
static int
-WinLink(LinkSource, LinkTarget, linkType)
+WinLink(LinkSource, LinkTarget, linkAction)
CONST TCHAR* LinkSource;
CONST TCHAR* LinkTarget;
- int linkType;
+ int linkAction;
{
WCHAR tempFileName[MAX_PATH];
TCHAR* tempFilePart;
@@ -220,21 +220,31 @@
Tcl_SetErrno(ENOTDIR);
return -1;
}
- if (linkType == 1) {
- /* Can't symlink files */
- return -1;
- }
+ if (linkAction & TCL_CREATE_HARD_LINK) {
if (!(*tclWinProcs->createHardLinkProc)(LinkSource, LinkTarget, NULL)) {
TclWinConvertError(GetLastError());
return -1;
}
return 0;
+ } else if (linkAction & TCL_CREATE_SYMBOLIC_LINK) {
+ /* Can't symlink files */
+ Tcl_SetErrno(ENOTDIR);
+ return -1;
} else {
- if (linkType == 2) {
- /* Can't hard link directories */
+ Tcl_SetErrno(ENODEV);
return -1;
}
+ } else {
+ if (linkAction & TCL_CREATE_SYMBOLIC_LINK) {
return WinSymLinkDirectory(LinkSource, LinkTarget);
+ } else if (linkAction & TCL_CREATE_HARD_LINK) {
+ /* Can't hard link directories */
+ Tcl_SetErrno(EISDIR);
+ return -1;
+ } else {
+ Tcl_SetErrno(ENODEV);
+ return -1;
+ }
}
}
@@ -1855,10 +1865,10 @@
#ifdef S_IFLNK
Tcl_Obj*
-TclpObjLink(pathPtr, toPtr, linkType)
+TclpObjLink(pathPtr, toPtr, linkAction)
Tcl_Obj *pathPtr;
Tcl_Obj *toPtr;
- int linkType;
+ int linkAction;
{
if (toPtr != NULL) {
int res;
@@ -1867,9 +1877,7 @@
if (LinkSource == NULL || LinkTarget == NULL) {
return NULL;
}
- /* We don't recognise these codes */
- if (linkType < 0 || linkType > 2) return NULL;
- res = WinLink(LinkSource, LinkTarget, linkType);
+ res = WinLink(LinkSource, LinkTarget, linkAction);
if (res == 0) {
return toPtr;
} else {
@@ -1948,11 +1956,11 @@
}
+#if 0
/*
* This function could be thoroughly tested and then substituted in
* below to speed up file normalization on Windows NT/2000/XP
*/
-#if 0
void WinGetLongPathName(CONST TCHAR* origPath, Tcl_DString *dsPtr);
@@ -2023,15 +2031,24 @@
#endif
+/*
+ * We have two different implementations of file normalization which
+ * can be turned on or off here. They should both agree for all files,
+ * and timings show the 'TCLWIN_NEW_NORM' version is about 10% faster.
+ */
+#define TCLWIN_NEW_NORM
/*
*---------------------------------------------------------------------------
*
* TclpObjNormalizePath --
*
- * This function scans through a path specification and replaces
- * it, in place, with a normalized version. On windows this
- * means using the 'longname'.
+ * This function scans through a path specification and replaces it,
+ * in place, with a normalized version. On Windows NT/2000/XP this
+ * means using the 'longname', and expanding any symbolic links
+ * contained within the path. On Win95/98/ME it means using the
+ * short form of the name (because the APIs to get at the long form
+ * are much too slow).
*
* Results:
* The new 'nextCheckpoint' value, giving as far as we could
@@ -2100,9 +2117,10 @@
*lastValidPathEnd = '\0';
}
/*
- * If we get here, we found a valid path, which we've converted to
- * short form, and the valid string ends at or before 'lastValidPathEnd'
- * and the invalid string starts at 'lastValidPathEnd'.
+ * If we get here, we found a valid path, which we've converted
+ * to short form, and the valid string ends at or before
+ * 'lastValidPathEnd' and the invalid string starts at
+ * 'lastValidPathEnd'.
*/
/* Copy over the valid part of the path and find its length */
@@ -2129,44 +2147,17 @@
} else {
/* We're on WinNT or 2000 or XP */
CONST char *nativePath;
-#if 0
- /*
- * We don't use this simpler version, because the speed
- * increase does not seem significant at present and the version
- * below is thoroughly debugged.
- */
- int nativeLen;
- Tcl_DString eDs;
- nativePath = Tcl_UtfToExternalDString(NULL, path, -1, &ds);
- nativeLen = Tcl_DStringLength(&ds);
- WinGetLongPathName(nativePath, &eDs);
- /*
- * We need to add code here to calculate the new value of
- * 'nextCheckpoint' -- i.e. the longest part of the path
- * which is an existing file.
- */
- Tcl_SetStringObj(pathPtr, Tcl_DStringValue(&eDs), Tcl_DStringLength(&eDs));
- Tcl_DStringFree(&eDs);
- Tcl_DStringFree(&ds);
-#else
char *currentPathEndPosition;
Tcl_Obj *temp = NULL;
WIN32_FILE_ATTRIBUTE_DATA data;
+ int isDrive = 1;
+#ifdef TCLWIN_NEW_NORM
+ /* This will hold the normalized string */
+ Tcl_DString dsNorm;
+ Tcl_DStringInit(&dsNorm);
+#endif
nativePath = Tcl_WinUtfToTChar(path, -1, &ds);
- /*
- * We currently don't use this because we have to check
- * each path component for reparse points.
- */
- if (0 && (*tclWinProcs->getFileAttributesExProc)(nativePath,
- GetFileExInfoStandard,
- &data) == TRUE) {
- currentPathEndPosition = path + pathLen;
- nextCheckpoint = pathLen;
- lastValidPathEnd = currentPathEndPosition;
- Tcl_DStringFree(&ds);
- } else {
- int isDrive = 1;
Tcl_DStringFree(&ds);
currentPathEndPosition = path + nextCheckpoint;
while (1) {
@@ -2182,11 +2173,19 @@
break;
}
- /* File does exist if we get here */
+ /*
+ * File 'nativePath' does exist if we get here. We
+ * now want to check if it is a symlink and otherwise
+ * continue with the rest of the path.
+ */
/*
* Check for symlinks, except at last component
- * of path (we don't follow final symlinks)
+ * of path (we don't follow final symlinks). Also
+ * a drive (C:/) for example, may sometimes have
+ * the reparse flag set for some reason I don't
+ * understand. We therefore don't perform this
+ * check for drives.
*/
if (cur != 0 && !isDrive && (data.dwFileAttributes
& FILE_ATTRIBUTE_REPARSE_POINT)) {
@@ -2194,28 +2193,67 @@
if (to != NULL) {
/* Read the reparse point ok */
Tcl_GetStringFromObj(to, &pathLen);
- nextCheckpoint = pathLen;
+ nextCheckpoint = 0; /* pathLen */
Tcl_AppendToObj(to, currentPathEndPosition, -1);
+ /* Convert link to forward slashes */
+ for (path = Tcl_GetString(to); *path != 0; path++) {
+ if (*path == '\\') *path = '/';
+ }
path = Tcl_GetString(to);
currentPathEndPosition = path + nextCheckpoint;
if (temp != NULL) {
Tcl_DecrRefCount(temp);
}
temp = to;
+ /* Reset variables so we can restart normalization */
+ isDrive = 1;
+#ifdef TCLWIN_NEW_NORM
+ Tcl_DStringFree(&dsNorm);
+ Tcl_DStringInit(&dsNorm);
+#endif
+ Tcl_DStringFree(&ds);
+ continue;
+ }
}
+#ifdef TCLWIN_NEW_NORM
+ /*
+ * Now we convert the tail of the current path to its
+ * 'long form', and append it to 'dsNorm' which holds
+ * the current normalized path
+ */
+ if (isDrive) {
+ WCHAR drive = ((WCHAR*)nativePath)[0];
+ if (drive >= L'a') {
+ drive -= (L'a' - L'A');
+ ((WCHAR*)nativePath)[0] = drive;
}
+ Tcl_DStringAppend(&dsNorm,nativePath,Tcl_DStringLength(&ds));
+ } else {
+ WIN32_FIND_DATAW fData;
+ HANDLE handle;
- Tcl_DStringFree(&ds);
- lastValidPathEnd = currentPathEndPosition;
- if (0) {
- WIN32_FIND_DATAT fdata;
- CONST TCHAR *nativeName;
- (*tclWinProcs->findFirstFileProc)(nativePath, &fdata);
- nativeName = (TCHAR *) fdata.w.cAlternateFileName;
- if (fdata.w.cFileName[0] != '\0') {
- nativeName = (TCHAR *) fdata.w.cFileName;
+ handle = FindFirstFileW((WCHAR*)nativePath, &fData);
+ if (handle == INVALID_HANDLE_VALUE) {
+ /* This is usually the '/' in 'c:/' at end of string */
+ Tcl_DStringAppend(&dsNorm,(CONST char*)L"/",
+ sizeof(WCHAR));
+ } else {
+ WCHAR *nativeName;
+ if (fData.cFileName[0] != '\0') {
+ nativeName = fData.cFileName;
+ } else {
+ nativeName = fData.cAlternateFileName;
+ }
+ FindClose(handle);
+ Tcl_DStringAppend(&dsNorm,(CONST char*)L"/",
+ sizeof(WCHAR));
+ Tcl_DStringAppend(&dsNorm,(TCHAR*)nativeName,
+ wcslen(nativeName)*sizeof(WCHAR));
}
}
+#endif
+ Tcl_DStringFree(&ds);
+ lastValidPathEnd = currentPathEndPosition;
if (cur == 0) {
break;
}
@@ -2228,16 +2266,46 @@
currentPathEndPosition++;
}
nextCheckpoint = currentPathEndPosition - path;
- }
+
if (lastValidPathEnd != NULL) {
+#ifdef TCLWIN_NEW_NORM
+ /*
+ * Concatenate the normalized string in dsNorm with the
+ * tail of the path which we didn't recognise. The
+ * string in dsNorm is in the native encoding, so we
+ * have to convert it to Utf.
+ */
+ Tcl_DString dsTemp;
+ Tcl_WinTCharToUtf(Tcl_DStringValue(&dsNorm),
+ Tcl_DStringLength(&dsNorm), &dsTemp);
+ nextCheckpoint = Tcl_DStringLength(&dsTemp);
+ if (*lastValidPathEnd != 0) {
+ /* Not the end of the string */
+ int len;
+ char *path;
Tcl_Obj *tmpPathPtr;
+ tmpPathPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsTemp),
+ nextCheckpoint);
+ Tcl_AppendToObj(tmpPathPtr, lastValidPathEnd, -1);
+ path = Tcl_GetStringFromObj(tmpPathPtr, &len);
+ Tcl_SetStringObj(pathPtr, path, len);
+ Tcl_DecrRefCount(tmpPathPtr);
+ } else {
+ /* End of string was reached above */
+ Tcl_SetStringObj(pathPtr, Tcl_DStringValue(&dsTemp),
+ nextCheckpoint);
+ }
+ Tcl_DStringFree(&dsTemp);
+#else
/*
* The leading end of the path description was acceptable to
- * us. We therefore convert it to its long form, and return
+ * us. We therefore convert it to its long form (which is
+ * used by Tcl as a unique normalized form), and return
* that.
*/
- Tcl_Obj* objPtr = NULL;
int endOfString;
+ Tcl_Obj *tmpPathPtr;
+ Tcl_Obj* objPtr = NULL;
int useLength = lastValidPathEnd - path;
if (*lastValidPathEnd == 0) {
tmpPathPtr = Tcl_NewStringObj(path, useLength);
@@ -2269,7 +2337,10 @@
Tcl_DecrRefCount(objPtr);
}
Tcl_DecrRefCount(tmpPathPtr);
+#endif
}
+#ifdef TCLWIN_NEW_NORM
+ Tcl_DStringFree(&dsNorm);
#endif
}
return nextCheckpoint;
