summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog18
-rw-r--r--doc/FileSystem.342
-rw-r--r--doc/file.n33
-rw-r--r--generic/tcl.decls4
-rw-r--r--generic/tcl.h13
-rw-r--r--generic/tclCmdAH.c100
-rw-r--r--generic/tclIOUtil.c23
-rw-r--r--generic/tclTest.c5
-rw-r--r--mac/tclMacFile.c34
-rw-r--r--tests/cmdAH.test28
-rw-r--r--tests/fCmd.test127
-rw-r--r--tests/fileName.test14
-rw-r--r--tests/fileSystem.test71
-rw-r--r--unix/tclUnixFile.c31
-rw-r--r--win/tclWinFile.c297
15 files changed, 594 insertions, 246 deletions
diff --git a/ChangeLog b/ChangeLog
index d34dac4..289b8b6 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,21 @@
+2002-06-21 Vince Darley <vincentdarley@users.sourceforge.net>
+
+ * tests/cmdAH.test: Added TIP#99 implementation
+ * tests/fCmd.test: of 'file link'. Supports creation
+ * tests/fileName.test: of symbolic and hard links in the
+ * tests/fileSystem.test: native filesystems and in vfs's,
+ * generic/tclTest.c: when the individual filesystem
+ * generic/tclCmdAH.c: supports the concept.
+ * generic/tclIOUtil.c:
+ * generic/tcl.h:
+ * generic/tcl.decls:
+ * doc/FileSystem.3:
+ * doc/file.n:
+ * mac/tclMacFile.c:
+ * unix/tclUnixFile.c:
+ * win/tclWinFile.c: Also enhanced speed of 'file normalize' on
+ Windows.
+
2002-06-20 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclBasic.c (TclEvalObjvInternal): fix for [Bug 571385]
diff --git a/doc/FileSystem.3 b/doc/FileSystem.3
index c38bcf4..747f5c4 100644
--- a/doc/FileSystem.3
+++ b/doc/FileSystem.3
@@ -4,7 +4,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" RCS: @(#) $Id: FileSystem.3,v 1.25 2002/06/13 09:39:59 vincentdarley Exp $
+'\" RCS: @(#) $Id: FileSystem.3,v 1.26 2002/06/21 14:22:28 vincentdarley Exp $
'\"
.so man.macros
.TH Filesystem 3 8.4 Tcl "Tcl Library Procedures"
@@ -64,7 +64,7 @@ int
\fBTcl_FSMatchInDirectory\fR(\fIinterp, result, pathPtr, pattern, types\fR)
.sp
Tcl_Obj*
-\fBTcl_FSLink\fR(\fIpathPtr, toPtr, linkType\fR)
+\fBTcl_FSLink\fR(\fIlinkNamePtr, toPtr, linkAction\fR)
.sp
int
\fBTcl_FSLstat\fR(\fIpathPtr, statPtr\fR)
@@ -343,18 +343,22 @@ matched using the logic of 'string match'. To handle recursion, Tcl
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
+extends it to support the creation of links. The appropriate function
+for the filesystem to which linkNamePtr 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
+\fIlinkNamePtr\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
@@ -1030,19 +1034,21 @@ only if the filesystem supports links, and may otherwise be NULL.
.PP
.CS
typedef Tcl_Obj* Tcl_FSLinkProc(
- Tcl_Obj *\fIpathPtr\fR,
+ Tcl_Obj *\fIlinkNamePtr\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
contents of a link. The result is a Tcl_Obj specifying the contents of
-the symbolic link given by 'path', or NULL if the symbolic link could
+the link given by \fIlinkNamePtr\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 \fItoPtr\fR
is not NULL, the function should attempt to create a link. The result
in this case should be \fItoPtr\fR if the link was successful and NULL
-otherwise. In this case the result is not owned by the caller.
+otherwise. In this case the result is not owned by the caller. See
+the documentation for \fBTcl_FSLink\fR for the correct interpretation
+of the \fIlinkAction\fR flags.
.SH LISTVOLUMESPROC
.PP
Function to list any filesystem volumes added by this filesystem.
diff --git a/doc/file.n b/doc/file.n
index 6d04f90..cf558ec 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.19 2002/06/20 00:50:48 jenglish Exp $
+'\" RCS: @(#) $Id: file.n,v 1.20 2002/06/21 14:22:28 vincentdarley Exp $
'\"
.so man.macros
.TH file n 8.3 Tcl "Tcl Built-In Commands"
@@ -191,6 +191,37 @@ is always canonical for the current platform: \fB/\fR for Unix and
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
diff --git a/generic/tcl.decls b/generic/tcl.decls
index ef74bdb..69ebc9c 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -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: tcl.decls,v 1.89 2002/06/13 09:39:59 vincentdarley Exp $
+# RCS: @(#) $Id: tcl.decls,v 1.90 2002/06/21 14:22:28 vincentdarley Exp $
library tcl
@@ -1577,7 +1577,7 @@ declare 445 generic {
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,
diff --git a/generic/tcl.h b/generic/tcl.h
index 0405cb4..f74f18a 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tcl.h,v 1.128 2002/06/18 00:12:44 davygrvy Exp $
+ * RCS: @(#) $Id: tcl.h,v 1.129 2002/06/21 14:22:28 vincentdarley Exp $
*/
#ifndef _TCL
@@ -1840,6 +1840,17 @@ typedef struct Tcl_Filesystem {
*/
} 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
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 4cf7eb1..bc6b655 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.25 2002/06/13 09:40:00 vincentdarley Exp $
+ * RCS: @(#) $Id: tclCmdAH.c,v 1.26 2002/06/21 14:22:28 vincentdarley Exp $
*/
#include "tclInt.h"
@@ -791,8 +791,8 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
"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 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
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,
@@ -955,6 +955,96 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
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 (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;
+ }
+ if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ /* Create link from source to target */
+ contents = Tcl_FSLink(objv[index], objv[index+1], linkAction);
+ if (contents == NULL) {
+ /*
+ * We handle two common error cases specially, and
+ * for all other errors, we use the standard posix
+ * error message.
+ */
+ if (errno == EEXIST) {
+ Tcl_AppendResult(interp, "could not create new link \"",
+ Tcl_GetString(objv[index]),
+ "\": that path already exists", (char *) NULL);
+ } else if (errno == ENOENT) {
+ Tcl_AppendResult(interp, "could not create new link \"",
+ Tcl_GetString(objv[index]),
+ "\" since target \"",
+ Tcl_GetString(objv[index+1]),
+ "\" doesn't exist",
+ (char *) NULL);
+ } else {
+ Tcl_AppendResult(interp, "could not create new link \"",
+ Tcl_GetString(objv[index]), "\" pointing to \"",
+ Tcl_GetString(objv[index+1]), "\": ",
+ Tcl_PosixError(interp), (char *) NULL);
+ }
+ return TCL_ERROR;
+ }
+ } else {
+ if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ /* 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: {
char *varName;
Tcl_StatBuf buf;
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index 2bf584c..041f5b8 100644
--- a/generic/tclIOUtil.c
+++ b/generic/tclIOUtil.c
@@ -17,7 +17,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclIOUtil.c,v 1.49 2002/06/13 09:40:00 vincentdarley Exp $
+ * RCS: @(#) $Id: tclIOUtil.c,v 1.50 2002/06/21 14:22:28 vincentdarley Exp $
*/
#include "tclInt.h"
@@ -2690,34 +2690,37 @@ FSUnloadTempFile(clientData)
* 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);
}
}
/*
diff --git a/generic/tclTest.c b/generic/tclTest.c
index 1b45e81..14e8ce7 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclTest.c,v 1.50 2002/06/13 09:40:00 vincentdarley Exp $
+ * RCS: @(#) $Id: tclTest.c,v 1.51 2002/06/21 14:22:28 vincentdarley Exp $
*/
#define TCL_TEST
@@ -2007,7 +2007,8 @@ TestfilelinkCmd(clientData, interp, objc, objv)
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 \"",
diff --git a/mac/tclMacFile.c b/mac/tclMacFile.c
index 07c1195..a25c5db 100644
--- a/mac/tclMacFile.c
+++ b/mac/tclMacFile.c
@@ -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: tclMacFile.c,v 1.22 2002/06/13 09:40:00 vincentdarley Exp $
+ * RCS: @(#) $Id: tclMacFile.c,v 1.23 2002/06/21 14:22:29 vincentdarley Exp $
*/
/*
@@ -686,7 +686,8 @@ TclpReadlink(
* Remove ending colons if they exist.
*/
- while ((Tcl_DStringLength(&ds) != 0) && (Tcl_DStringValue(&ds)[Tcl_DStringLength(&ds) - 1] == ':')) {
+ while ((Tcl_DStringLength(&ds) != 0)
+ && (Tcl_DStringValue(&ds)[Tcl_DStringLength(&ds) - 1] == ':')) {
Tcl_DStringSetLength(&ds, Tcl_DStringLength(&ds) - 1);
}
@@ -705,7 +706,8 @@ TclpReadlink(
*/
if (end != NULL) {
- err = FSpLocationFromPath(Tcl_DStringLength(&ds), Tcl_DStringValue(&ds), &fileSpec);
+ err = FSpLocationFromPath(Tcl_DStringLength(&ds),
+ Tcl_DStringValue(&ds), &fileSpec);
if (err != noErr) {
Tcl_DStringFree(&ds);
errno = EINVAL;
@@ -774,7 +776,8 @@ TclpReadlink(
}
static int
-TclpObjStatAlias _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_StatBuf *bufPtr, Boolean resolveLink));
+TclpObjStatAlias _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_StatBuf *bufPtr,
+ Boolean resolveLink));
/*
@@ -1145,15 +1148,32 @@ TclpTempFileName()
#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) {
- return NULL;
+ if (TclpObjAccess(pathPtr, F_OK) != -1) {
+ /* src exists */
+ errno = EEXIST;
+ return NULL;
+ }
+ if (TclpObjAccess(toPtr, F_OK) == -1) {
+ /* target doesn't exist */
+ errno = ENOENT;
+ return NULL;
+ }
+
+ if (linkAction & TCL_CREATE_SYMBOLIC_LINK) {
+ /* Needs to create a new link */
+ return NULL;
+ } else {
+ errno = ENODEV;
+ return NULL;
+ }
} else {
Tcl_DString ds;
Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
diff --git a/tests/cmdAH.test b/tests/cmdAH.test
index cd0cce8..ff715e0 100644
--- a/tests/cmdAH.test
+++ b/tests/cmdAH.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: cmdAH.test,v 1.20 2002/05/07 18:03:04 vincentdarley Exp $
+# RCS: @(#) $Id: cmdAH.test,v 1.21 2002/06/21 14:22:29 vincentdarley Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -168,7 +168,7 @@ test cmdAH-5.1 {Tcl_FileObjCmd} {
} {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 @@ test cmdAH-22.3 {Tcl_FileObjCmd: isfile} {file isfile dir.file} 0
# 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 @@ test cmdAH-29.4 {Tcl_FileObjCmd: type} {unixOnly nonPortable} {
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-29.5 {Tcl_FileObjCmd: type} {
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}}
diff --git a/tests/fCmd.test b/tests/fCmd.test
index a5cb889..964f31d 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.13 2002/06/13 13:17:06 vincentdarley Exp $
+# RCS: @(#) $Id: fCmd.test,v 1.14 2002/06/21 14:22:29 vincentdarley Exp $
#
if {[lsearch [namespace children] ::tcltest] == -1} {
@@ -2163,36 +2163,37 @@ test fCmd-27.6 {TclFileAttrsCmd - setting more than one option} {foundGroup} {
list [catch {eval file attributes foo.tmp [lrange $attrs 0 3]} msg] $msg [file delete -force -- foo.tmp]
} {0 {} {}}
-if {[string equal testfilelink [info commands testfilelink]]} {
- tcltest::testConstraint testfilelink 1
+tcltest::testConstraint hasLinks 1
- if {[string equal $tcl_platform(platform) "windows"]} {
- if {[string index $tcl_platform(osVersion) 0] >= 5 \
- && ([lindex [file system [temporaryDirectory]] 1] == "NTFS")} {
- tcltest::testConstraint linkDirectory 1
- tcltest::testConstraint linkFile 1
- } else {
- tcltest::testConstraint linkDirectory 0
- tcltest::testConstraint linkFile 0
- }
- } else {
- tcltest::testConstraint linkFile 1
+if {[string equal $tcl_platform(platform) "windows"]} {
+ if {[string index $tcl_platform(osVersion) 0] >= 5 \
+ && ([lindex [file system [temporaryDirectory]] 1] == "NTFS")} {
tcltest::testConstraint linkDirectory 1
+ tcltest::testConstraint linkFile 1
+ } else {
+ tcltest::testConstraint linkDirectory 0
+ tcltest::testConstraint linkFile 0
}
-
} else {
- tcltest::testConstraint testfilelink 0
- tcltest::testConstraint linkDirectory 0
- tcltest::testConstraint linkFile 0
+ tcltest::testConstraint linkFile 1
+ tcltest::testConstraint linkDirectory 1
}
-test fCmd-28.1 {testfilelink} {testfilelink} {
- list [catch {testfilelink} msg] $msg
-} {1 {wrong # args: should be "testfilelink source ?target?"}}
+test fCmd-28.1 {file link} {hasLinks} {
+ list [catch {file link} msg] $msg
+} {1 {wrong # args: should be "file link ?-linktype? source ?target?"}}
+
+test fCmd-28.2 {file link} {hasLinks} {
+ list [catch {file link a b c d} msg] $msg
+} {1 {wrong # args: should be "file link ?-linktype? 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.3 {file link} {hasLinks} {
+ list [catch {file link abc b c} msg] $msg
+} {1 {bad switch "abc": must be -symbolic or -hard}}
+
+test fCmd-28.4 {file link} {hasLinks} {
+ 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 +2202,76 @@ makeDirectory abc2.dir
makeFile contents abc.file
makeFile contents abc2.file
-test fCmd-28.3 {testfilelink} {linkDirectory winOnly} {
- list [catch {testfilelink abc.dir abc2.dir} msg] $msg
-} {1 {could not create link from "abc.dir" to "abc2.dir": file already exists}}
+test fCmd-28.5 {file link: source already exists} {linkDirectory} {
+ list [catch {file link abc.dir abc2.dir} msg] $msg
+} {1 {could not create new link "abc.dir": that path already exists}}
+
+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 new link "abc.link" pointing to "abc.dir": illegal operation on a directory}}
-test fCmd-28.4 {testfilelink} {linkFile winOnly} {
- list [catch {testfilelink abc.file abc2.file} msg] $msg
-} {1 {could not create link from "abc.file" to "abc2.file": file already exists}}
+test fCmd-28.7 {file link: source already exists} {linkFile} {
+ list [catch {file link abc.file abc2.file} msg] $msg
+} {1 {could not create new link "abc.file": that path 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 new link "abc.link" pointing 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
-} {1 {could not create link from "abc.link" to "abc2.doesnt": no such file or directory}}
+ list [catch {file link abc.link abc2.doesnt} msg] $msg
+} {1 {could not create new link "abc.link" since target "abc2.doesnt" doesn't exist}}
-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],
+ # depending on whether 'cd' actually moves to the destination
+ # of a link, or simply treats the link as a directory.
+ # (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
-} {1 {could not create link from "abc.link" to "abc.dir": file already exists}}
+ list [catch {file link abc.link abc.dir} msg] $msg
+} {1 {could not create new link "abc.link": that path 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 +2280,17 @@ file delete -force abc2.link
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]]
diff --git a/tests/fileName.test b/tests/fileName.test
index cdf3572..5ded8c5 100644
--- a/tests/fileName.test
+++ b/tests/fileName.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: fileName.test,v 1.22 2002/05/30 09:27:11 vincentdarley Exp $
+# RCS: @(#) $Id: fileName.test,v 1.23 2002/06/21 14:22:29 vincentdarley Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -1172,12 +1172,12 @@ test filename-11.17.1 {Tcl_GlobCmd} {pcOnly macOnly} {
[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 @@ test filename-11.17.2 {Tcl_GlobCmd} {unixOnly notRoot} {
} [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 @@ test filename-11.17.3 {Tcl_GlobCmd} {unixOnly notRoot} {
[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 *]
diff --git a/tests/fileSystem.test b/tests/fileSystem.test
index eb3f6cb..5e5e9c8 100644
--- a/tests/fileSystem.test
+++ b/tests/fileSystem.test
@@ -32,60 +32,103 @@ makeDirectory dir.file
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
+ tcltest::testConstraint hasLinks 0
} else {
- tcltest::testConstraint links 1
+ tcltest::testConstraint hasLinks 1
}
-test filesystem-1.0 {link normalisation} {links} {
+test filesystem-1.0 {link normalisation} {hasLinks} {
string equal [file normalize gorp.file] [file normalize link.file]
} {0}
-test filesystem-1.1 {link normalisation} {links} {
+test filesystem-1.1 {link normalisation} {hasLinks} {
string equal [file normalize dir.file] [file normalize dir.link]
} {0}
-test filesystem-1.2 {link normalisation} {links macOrUnix} {
+test filesystem-1.2 {link normalisation} {hasLinks macOrUnix} {
string equal [file normalize [file join gorp.file foo]] \
[file normalize [file join link.file foo]]
} {1}
-test filesystem-1.3 {link normalisation} {links} {
+test filesystem-1.3 {link normalisation} {hasLinks} {
string equal [file normalize [file join dir.file foo]] \
[file normalize [file join dir.link foo]]
} {1}
-test filesystem-1.4 {link normalisation} {links} {
+test filesystem-1.4 {link normalisation} {hasLinks} {
string equal [file normalize [file join dir.file inside.file]] \
[file normalize [file join dir.link inside.file]]
} {1}
-test filesystem-1.5 {link normalisation} {links} {
+test filesystem-1.5 {link normalisation} {hasLinks} {
string equal [file normalize [file join dir.file linkinside.file]] \
[file normalize [file join dir.file linkinside.file]]
} {1}
-test filesystem-1.6 {link normalisation} {links} {
+test filesystem-1.6 {link normalisation} {hasLinks} {
string equal [file normalize [file join dir.file linkinside.file]] \
[file normalize [file join dir.link inside.file]]
} {0}
-test filesystem-1.7 {link normalisation} {links macOrUnix} {
+test filesystem-1.7 {link normalisation} {hasLinks macOrUnix} {
string equal [file normalize [file join dir.link linkinside.file foo]] \
[file normalize [file join dir.file inside.file foo]]
} {1}
-test filesystem-1.8 {link normalisation} {links} {
+test filesystem-1.8 {link normalisation} {hasLinks} {
string equal [file normalize [file join dir.file linkinside.filefoo]] \
[file normalize [file join dir.link inside.filefoo]]
} {0}
+test filesystem-1.9 {link normalisation} {hasLinks} {
+ 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} {hasLinks} {
+ 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} {hasLinks} {
+ 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
diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c
index 9edd47e..6724778 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.23 2002/06/13 09:40:01 vincentdarley Exp $
+ * RCS: @(#) $Id: tclUnixFile.c,v 1.24 2002/06/21 14:22:29 vincentdarley Exp $
*/
#include "tclInt.h"
@@ -724,10 +724,10 @@ TclpObjStat(pathPtr, bufPtr)
#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 @@ TclpObjLink(pathPtr, toPtr, linkType)
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 {
diff --git a/win/tclWinFile.c b/win/tclWinFile.c
index b12fb2a..8c34b24 100644
--- a/win/tclWinFile.c
+++ b/win/tclWinFile.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: tclWinFile.c,v 1.32 2002/06/13 10:43:41 vincentdarley Exp $
+ * RCS: @(#) $Id: tclWinFile.c,v 1.33 2002/06/21 14:22:29 vincentdarley Exp $
*/
//#define _WIN32_WINNT 0x0500
@@ -162,7 +162,7 @@ static int WinIsDrive(CONST char *name, int nameLen);
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 @@ extern Tcl_Filesystem nativeFilesystem;
*--------------------------------------------------------------------
*/
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 @@ WinLink(LinkSource, LinkTarget, linkType)
Tcl_SetErrno(ENOTDIR);
return -1;
}
- if (linkType == 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;
- }
- if (!(*tclWinProcs->createHardLinkProc)(LinkSource, LinkTarget, NULL)) {
- TclWinConvertError(GetLastError());
+ } else {
+ Tcl_SetErrno(ENODEV);
return -1;
}
- return 0;
} else {
- if (linkType == 2) {
+ 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;
}
- return WinSymLinkDirectory(LinkSource, LinkTarget);
}
}
@@ -1855,10 +1865,10 @@ TclpObjLstat(pathPtr, statPtr)
#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 @@ TclpObjLink(pathPtr, toPtr, linkType)
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 @@ TclpFilesystemPathType(pathObjPtr)
}
+#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 @@ void WinGetLongPathName(CONST TCHAR* pszOriginal, Tcl_DString *dsPtr) {
#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 @@ TclpObjNormalizePath(interp, pathPtr, nextCheckpoint)
*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,115 +2147,165 @@ TclpObjNormalizePath(interp, pathPtr, nextCheckpoint)
} 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) {
- char cur = *currentPathEndPosition;
- if ((cur == '/' || cur == 0) && (path != currentPathEndPosition)) {
- /* Reached directory separator, or end of string */
- nativePath = Tcl_WinUtfToTChar(path,
- currentPathEndPosition - path, &ds);
- if ((*tclWinProcs->getFileAttributesExProc)(nativePath,
- GetFileExInfoStandard, &data) != TRUE) {
- /* File doesn't exist */
- Tcl_DStringFree(&ds);
- break;
- }
+ Tcl_DStringFree(&ds);
+ currentPathEndPosition = path + nextCheckpoint;
+ while (1) {
+ char cur = *currentPathEndPosition;
+ if ((cur == '/' || cur == 0) && (path != currentPathEndPosition)) {
+ /* Reached directory separator, or end of string */
+ nativePath = Tcl_WinUtfToTChar(path,
+ currentPathEndPosition - path, &ds);
+ if ((*tclWinProcs->getFileAttributesExProc)(nativePath,
+ GetFileExInfoStandard, &data) != TRUE) {
+ /* File doesn't exist */
+ Tcl_DStringFree(&ds);
+ break;
+ }
- /* File does exist if we get here */
-
- /*
- * Check for symlinks, except at last component
- * of path (we don't follow final symlinks)
- */
- if (cur != 0 && !isDrive && (data.dwFileAttributes
- & FILE_ATTRIBUTE_REPARSE_POINT)) {
- Tcl_Obj *to = WinReadLinkDirectory(nativePath);
- if (to != NULL) {
- /* Read the reparse point ok */
- Tcl_GetStringFromObj(to, &pathLen);
- nextCheckpoint = pathLen;
- Tcl_AppendToObj(to, currentPathEndPosition, -1);
- path = Tcl_GetString(to);
- currentPathEndPosition = path + nextCheckpoint;
- if (temp != NULL) {
- Tcl_DecrRefCount(temp);
- }
- temp = to;
+ /*
+ * 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). 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)) {
+ Tcl_Obj *to = WinReadLinkDirectory(nativePath);
+ if (to != NULL) {
+ /* Read the reparse point ok */
+ Tcl_GetStringFromObj(to, &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;
}
-
- 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;
- }
+ }
+#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;
}
- if (cur == 0) {
- break;
+ Tcl_DStringAppend(&dsNorm,nativePath,Tcl_DStringLength(&ds));
+ } else {
+ WIN32_FIND_DATAW fData;
+ HANDLE handle;
+
+ 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));
}
- /*
- * If we get here, we've got past one directory
- * delimiter, so we know it is no longer a drive
- */
- isDrive = 0;
}
- currentPathEndPosition++;
+#endif
+ Tcl_DStringFree(&ds);
+ lastValidPathEnd = currentPathEndPosition;
+ if (cur == 0) {
+ break;
+ }
+ /*
+ * If we get here, we've got past one directory
+ * delimiter, so we know it is no longer a drive
+ */
+ isDrive = 0;
}
- nextCheckpoint = currentPathEndPosition - path;
+ currentPathEndPosition++;
}
+ nextCheckpoint = currentPathEndPosition - path;
+
if (lastValidPathEnd != NULL) {
- Tcl_Obj *tmpPathPtr;
+#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 @@ TclpObjNormalizePath(interp, pathPtr, nextCheckpoint)
Tcl_DecrRefCount(objPtr);
}
Tcl_DecrRefCount(tmpPathPtr);
+#endif
}
+#ifdef TCLWIN_NEW_NORM
+ Tcl_DStringFree(&dsNorm);
#endif
}
return nextCheckpoint;
generated by cgit v0.12 at 2024-11-06 00:15:47 (GMT)