From 3db3abd0e6cfd42d48f513b1b4e7640fbb47c7c6 Mon Sep 17 00:00:00 2001 From: vincentdarley Date: Thu, 13 Jun 2002 09:39:58 +0000 Subject: vfs, winfs testsuite --- ChangeLog | 20 +++++ doc/FileSystem.3 | 9 ++- generic/tcl.decls | 4 +- generic/tcl.h | 4 +- generic/tclCmdAH.c | 4 +- generic/tclDecls.h | 6 +- generic/tclIOUtil.c | 7 +- generic/tclInt.h | 5 +- generic/tclTest.c | 82 +++++++++++++++++-- mac/tclMacFile.c | 5 +- tests/fCmd.test | 104 ++++++++++++++++++++++++- tests/fileSystem.test | 75 +++++++++++------- tests/winFile.test | 14 ++-- unix/tclUnixFile.c | 14 ++-- win/tclWin32Dll.c | 12 ++- win/tclWinFile.c | 212 ++++++++++++++++++++++++++++++++++++++++++++------ win/tclWinInt.h | 4 +- 17 files changed, 492 insertions(+), 89 deletions(-) diff --git a/ChangeLog b/ChangeLog index 3679e28..56b459b 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,23 @@ +2002-06-13 Vince Darley + + * tests/fCmd.test: + * tests/winFile.test: + * tests/fileSystem.test: + * generic/tclTest.c: + * generic/tclCmdAH.c: + * generic/tclIOUtil.c: + * doc/FileSystem.3: + * mac/tclMacFile.c: + * unix/tclUnixFile.c: + * win/tclWinFile.c: fixed up further so both compiles and + actually works with VC++ 5 or 6. + * win/tclWinInt.h: + * win/tclWin32Dll.c: cleaned up code and vfs tests and + added tests for the internal changes of 2002-06-12, to see + whether WinTcl on NTFS can coexist peacefully with links + in the filesystem. Added new test command 'testfilelink' + to enable the newer code to be tested. + 2002-06-12 Miguel Sofer * tclBasic.c (Tcl_DeleteTrace): fixed [Bug 568123] (thanks to diff --git a/doc/FileSystem.3 b/doc/FileSystem.3 index a9ec3e8..c38bcf4 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.24 2002/06/12 09:28:58 vincentdarley Exp $ +'\" RCS: @(#) $Id: FileSystem.3,v 1.25 2002/06/13 09:39:59 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\fR) +\fBTcl_FSLink\fR(\fIpathPtr, toPtr, linkType\fR) .sp int \fBTcl_FSLstat\fR(\fIpathPtr, statPtr\fR) @@ -354,7 +354,7 @@ 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 -is left available for future expansion). +and the \fIlinkType\fR field are left available for future expansion). .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 @@ -1031,7 +1031,8 @@ only if the filesystem supports links, and may otherwise be NULL. .CS typedef Tcl_Obj* Tcl_FSLinkProc( Tcl_Obj *\fIpathPtr\fR, - Tcl_Obj *\fItoPtr\fR); + Tcl_Obj *\fItoPtr\fR, + int \fIlinkType\fR); .CE .PP If \fItoPtr\fR is NULL, the function is being asked to read the diff --git a/generic/tcl.decls b/generic/tcl.decls index 7f10c97..ef74bdb 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.88 2002/06/12 09:28:58 vincentdarley Exp $ +# RCS: @(#) $Id: tcl.decls,v 1.89 2002/06/13 09:39:59 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) + Tcl_Obj * Tcl_FSLink(Tcl_Obj *pathPtr, Tcl_Obj *toPtr, int linkType) } declare 447 generic { int Tcl_FSRemoveDirectory(Tcl_Obj *pathPtr, diff --git a/generic/tcl.h b/generic/tcl.h index 0df69dd..c7dd3d2 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.124 2002/05/24 21:19:05 dkf Exp $ + * RCS: @(#) $Id: tcl.h,v 1.125 2002/06/13 09:40:00 vincentdarley Exp $ */ #ifndef _TCL @@ -1641,7 +1641,7 @@ typedef int (Tcl_FSFileAttrsSetProc) _ANSI_ARGS_((Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, Tcl_Obj *objPtr)); typedef Tcl_Obj* (Tcl_FSLinkProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, - Tcl_Obj *toPtr)); + Tcl_Obj *toPtr, int linkType)); typedef int (Tcl_FSLoadFileProc) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj *pathPtr, CONST char * sym1, CONST char * sym2, diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 500f988..4cf7eb1 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.24 2002/04/23 02:54:13 hobbs Exp $ + * RCS: @(#) $Id: tclCmdAH.c,v 1.25 2002/06/13 09:40:00 vincentdarley Exp $ */ #include "tclInt.h" @@ -1101,7 +1101,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } - contents = Tcl_FSLink(objv[2], NULL); + contents = Tcl_FSLink(objv[2], NULL, 0); if (contents == NULL) { Tcl_AppendResult(interp, "could not readlink \"", diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 8062d1e..f97b0fb 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclDecls.h,v 1.88 2002/06/12 09:28:58 vincentdarley Exp $ + * RCS: @(#) $Id: tclDecls.h,v 1.89 2002/06/13 09:40:00 vincentdarley Exp $ */ #ifndef _TCLDECLS @@ -1416,7 +1416,7 @@ EXTERN int Tcl_FSMatchInDirectory _ANSI_ARGS_(( Tcl_GlobTypeData * types)); /* 446 */ EXTERN Tcl_Obj * Tcl_FSLink _ANSI_ARGS_((Tcl_Obj * pathPtr, - Tcl_Obj * toPtr)); + Tcl_Obj * toPtr, int linkType)); /* 447 */ EXTERN int Tcl_FSRemoveDirectory _ANSI_ARGS_((Tcl_Obj * pathPtr, int recursive, Tcl_Obj ** errorPtr)); @@ -2061,7 +2061,7 @@ typedef struct TclStubs { int (*tcl_FSDeleteFile) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 443 */ int (*tcl_FSLoadFile) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * pathPtr, CONST char * sym1, CONST char * sym2, Tcl_PackageInitProc ** proc1Ptr, Tcl_PackageInitProc ** proc2Ptr, ClientData * clientDataPtr, Tcl_FSUnloadFileProc ** unloadProcPtr)); /* 444 */ int (*tcl_FSMatchInDirectory) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * result, Tcl_Obj * pathPtr, CONST char * pattern, Tcl_GlobTypeData * types)); /* 445 */ - Tcl_Obj * (*tcl_FSLink) _ANSI_ARGS_((Tcl_Obj * pathPtr, Tcl_Obj * toPtr)); /* 446 */ + Tcl_Obj * (*tcl_FSLink) _ANSI_ARGS_((Tcl_Obj * pathPtr, Tcl_Obj * toPtr, int linkType)); /* 446 */ int (*tcl_FSRemoveDirectory) _ANSI_ARGS_((Tcl_Obj * pathPtr, int recursive, Tcl_Obj ** errorPtr)); /* 447 */ int (*tcl_FSRenameFile) _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr)); /* 448 */ int (*tcl_FSLstat) _ANSI_ARGS_((Tcl_Obj * pathPtr, Tcl_StatBuf * buf)); /* 449 */ diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 0858a58..2bf584c 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.48 2002/06/12 09:28:58 vincentdarley Exp $ + * RCS: @(#) $Id: tclIOUtil.c,v 1.49 2002/06/13 09:40:00 vincentdarley Exp $ */ #include "tclInt.h" @@ -2708,15 +2708,16 @@ FSUnloadTempFile(clientData) */ Tcl_Obj * -Tcl_FSLink(pathPtr, toPtr) +Tcl_FSLink(pathPtr, toPtr, linkType) 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 */ { Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); if (fsPtr != NULL) { Tcl_FSLinkProc *proc = fsPtr->linkProc; if (proc != NULL) { - return (*proc)(pathPtr, toPtr); + return (*proc)(pathPtr, toPtr, linkType); } } /* diff --git a/generic/tclInt.h b/generic/tclInt.h index 60ea8e1..920d946 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.93 2002/06/11 15:42:21 msofer Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.94 2002/06/13 09:40:00 vincentdarley Exp $ */ #ifndef _TCLINT @@ -1859,7 +1859,8 @@ EXTERN int TclpMatchInDirectory _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *resultPtr, Tcl_Obj *pathPtr, CONST char *pattern, Tcl_GlobTypeData *types)); EXTERN Tcl_Obj* TclpObjGetCwd _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN Tcl_Obj* TclpObjLink _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_Obj *toPtr)); +EXTERN Tcl_Obj* TclpObjLink _ANSI_ARGS_((Tcl_Obj *pathPtr, + Tcl_Obj *toPtr, int linkType)); EXTERN int TclpObjChdir _ANSI_ARGS_((Tcl_Obj *pathPtr)); EXTERN Tcl_Obj* TclFileDirname _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj*pathPtr)); diff --git a/generic/tclTest.c b/generic/tclTest.c index 7958bf4..1b45e81 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.49 2002/04/23 03:48:33 hobbs Exp $ + * RCS: @(#) $Id: tclTest.c,v 1.50 2002/06/13 09:40:00 vincentdarley Exp $ */ #define TCL_TEST @@ -230,6 +230,8 @@ static int TestexprstringCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); static int TestfileCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +static int TestfilelinkCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TestfeventCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); static int TestgetassocdataCmd _ANSI_ARGS_((ClientData dummy, @@ -368,7 +370,7 @@ static int TestReportLoadFile _ANSI_ARGS_ ((Tcl_Interp *interp, ClientData *clientDataPtr, Tcl_FSUnloadFileProc **unloadProcPtr)); static Tcl_Obj * TestReportLink _ANSI_ARGS_ ((Tcl_Obj *path, - Tcl_Obj *to)); + Tcl_Obj *to, int linkType)); static CONST char** TestReportFileAttrStrings _ANSI_ARGS_ (( Tcl_Obj *fileName, Tcl_Obj **objPtrRef)); static int TestReportFileAttrsGet _ANSI_ARGS_ ((Tcl_Interp *interp, @@ -525,6 +527,8 @@ Tcltest_Init(interp) (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testfevent", TestfeventCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "testfilelink", TestfilelinkCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "testfile", TestfileCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testgetassocdata", TestgetassocdataCmd, @@ -1968,6 +1972,73 @@ TestexprstringCmd(clientData, interp, argc, argv) /* *---------------------------------------------------------------------- * + * TestfilelinkCmd -- + * + * This procedure implements the "testfilelink" command. It is used + * to test the effects of creating and manipulating filesystem links + * in Tcl. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May create a link on disk. + * + *---------------------------------------------------------------------- + */ + +static int +TestfilelinkCmd(clientData, interp, objc, objv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* The argument objects. */ +{ + Tcl_Obj *contents; + + if (objc < 2 || objc > 3) { + Tcl_WrongNumArgs(interp, 1, objv, "source ?target?"); + return TCL_ERROR; + } + + if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) { + return TCL_ERROR; + } + + if (objc == 3) { + /* Create link from source to target */ + contents = Tcl_FSLink(objv[1], objv[2], 0); + if (contents == NULL) { + Tcl_AppendResult(interp, "could not create link from \"", + Tcl_GetString(objv[1]), "\" to \"", + Tcl_GetString(objv[2]), "\": ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + } else { + /* Read link */ + contents = Tcl_FSLink(objv[1], NULL, 0); + if (contents == NULL) { + Tcl_AppendResult(interp, "could not read link \"", + Tcl_GetString(objv[1]), "\": ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + } + Tcl_SetObjResult(interp, contents); + if (objc == 2) { + /* + * If we are creating a link, this will actually just + * be objv[3], and we don't own it + */ + Tcl_DecrRefCount(contents); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TestgetassocdataCmd -- * * This procedure implements the "testgetassocdata" command. It is @@ -5760,12 +5831,13 @@ TestReportLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr, proc1Ptr, proc2Ptr, clientDataPtr, unloadProcPtr); } static Tcl_Obj * -TestReportLink(path, to) +TestReportLink(path, to, linkType) Tcl_Obj *path; /* Path of file to readlink or link */ Tcl_Obj *to; /* Path of file to link to, or NULL */ + int linkType; { - TestReport("link",path,NULL); - return Tcl_FSLink(TestReportGetNativePath(path),NULL); + TestReport("link",path,to); + return Tcl_FSLink(TestReportGetNativePath(path), to, linkType); } static int TestReportRenameFile(src, dst) diff --git a/mac/tclMacFile.c b/mac/tclMacFile.c index 210624b..07c1195 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.21 2002/05/02 20:15:20 vincentdarley Exp $ + * RCS: @(#) $Id: tclMacFile.c,v 1.22 2002/06/13 09:40:00 vincentdarley Exp $ */ /* @@ -1145,9 +1145,10 @@ TclpTempFileName() #ifdef S_IFLNK Tcl_Obj* -TclpObjLink(pathPtr, toPtr) +TclpObjLink(pathPtr, toPtr, linkType) Tcl_Obj *pathPtr; Tcl_Obj *toPtr; + int linkType; { Tcl_Obj* link = NULL; diff --git a/tests/fCmd.test b/tests/fCmd.test index 9b3d997..b04262f 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.11 2001/09/04 18:06:34 vincentdarley Exp $ +# RCS: @(#) $Id: fCmd.test,v 1.12 2002/06/13 09:40:00 vincentdarley Exp $ # if {[lsearch [namespace children] ::tcltest] == -1} { @@ -2163,6 +2163,108 @@ 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 + + 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 + tcltest::testConstraint linkDirectory 1 + } + +} else { + tcltest::testConstraint testfilelink 0 + tcltest::testConstraint linkDirectory 0 + 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?"}} + +catch {file delete -force abc.dir} +catch {file delete -force abc2.dir} +makeDirectory abc.dir +makeDirectory abc2.dir +makeFile contents abc.file +makeFile contents abc2.file + +test fCmd-28.3 {testfilelink} {linkDirectory} { + 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.4 {testfilelink} {linkFile} { + 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.5 {testfilelink} {linkFile} { + file delete -force abc.link + list [catch {testfilelink abc.link abc.file} msg] $msg +} {0 abc.file} + +catch {file delete -force abc.link} + +test fCmd-28.6 {testfilelink} {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}} + +test fCmd-28.7 {testfilelink} {linkDirectory} { + file delete -force abc.link + list [catch {testfilelink abc.link abc.dir} msg] $msg +} {0 abc.dir} + +test fCmd-28.7.1 {testfilelink} {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}} + +test fCmd-28.8 {testfilelink: 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} { + file delete -force abc.link + testfilelink abc.link abc.dir + file copy abc.link abc2.link + list [file type abc2.link] [file tail [testfilelink abc2.link]] +} {link abc.dir} + +file delete -force abc.link +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} { + file delete -force abc.link + testfilelink abc.link abc.dir + glob -dir abc.link -tails * +} {abc.file abc2.file} + +test fCmd-28.11 {testfilelink: glob -type l} {linkDirectory} { + glob -dir [pwd] -type l -tails abc* +} {abc.link} + +test fCmd-28.12 {testfilelink: glob -type d} {linkDirectory} { + lsort [glob -dir [pwd] -type d -tails abc*] +} [lsort [list abc.link abc.dir abc2.dir]] + +file delete -force abc.link + # cleanup cleanup ::tcltest::cleanupTests diff --git a/tests/fileSystem.test b/tests/fileSystem.test index 5a0713a..eb3f6cb 100644 --- a/tests/fileSystem.test +++ b/tests/fileSystem.test @@ -12,57 +12,78 @@ package require tcltest namespace eval ::tcl::test::fileSystem { - namespace import ::tcltest::cleanupTests - namespace import ::tcltest::makeDirectory - namespace import ::tcltest::makeFile - namespace import ::tcltest::removeDirectory - namespace import ::tcltest::removeFile - namespace import ::tcltest::test + catch { + namespace import ::tcltest::cleanupTests + namespace import ::tcltest::makeDirectory + namespace import ::tcltest::makeFile + namespace import ::tcltest::removeDirectory + namespace import ::tcltest::removeFile + namespace import ::tcltest::test + } + + catch { + file delete -force link.file + file delete -force dir.link + file delete -force [file join dir.file linkinside.file] + } makeFile "test file" gorp.file makeDirectory dir.file makeFile "test file in directory" [file join dir.file inside.file] -# It would be good to be able to make these work on MacOS too. -# If we added 'file link from to' we could easily do that. -catch {exec ln -s gorp.file link.file} -catch {exec ln -s inside.file dir.file/linkinside.file} -catch {exec ln -s dir.file dir.link} +if {[catch { + testfilelink link.file gorp.file + testfilelink \ + [file join dir.file linkinside.file] \ + [file join dir.file inside.file] + testfilelink dir.link dir.file +}]} { + tcltest::testConstraint links 0 +} else { + tcltest::testConstraint links 1 +} -test filesystem-1.0 {link normalisation} {unixOnly} { +test filesystem-1.0 {link normalisation} {links} { string equal [file normalize gorp.file] [file normalize link.file] } {0} -test filesystem-1.1 {link normalisation} {unixOnly} { +test filesystem-1.1 {link normalisation} {links} { string equal [file normalize dir.file] [file normalize dir.link] } {0} -test filesystem-1.2 {link normalisation} {unixOnly} { - string equal [file normalize gorp.file/foo] [file normalize link.file/foo] +test filesystem-1.2 {link normalisation} {links macOrUnix} { + string equal [file normalize [file join gorp.file foo]] \ + [file normalize [file join link.file foo]] } {1} -test filesystem-1.3 {link normalisation} {unixOnly} { - string equal [file normalize dir.file/foo] [file normalize dir.link/foo] +test filesystem-1.3 {link normalisation} {links} { + string equal [file normalize [file join dir.file foo]] \ + [file normalize [file join dir.link foo]] } {1} -test filesystem-1.4 {link normalisation} {unixOnly} { - string equal [file normalize dir.file/inside.file] [file normalize dir.link/inside.file] +test filesystem-1.4 {link normalisation} {links} { + 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} {unixOnly} { - string equal [file normalize dir.file/linkinside.file] [file normalize dir.file/linkinside.file] +test filesystem-1.5 {link normalisation} {links} { + 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} {unixOnly} { - string equal [file normalize dir.file/linkinside.file] [file normalize dir.link/inside.file] +test filesystem-1.6 {link normalisation} {links} { + 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} {unixOnly} { - string equal [file normalize dir.link/linkinside.file/foo] [file normalize dir.file/inside.file/foo] +test filesystem-1.7 {link normalisation} {links 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} {unixOnly} { - string equal [file normalize dir.file/linkinside.filefoo] [file normalize dir.link/inside.filefoo] +test filesystem-1.8 {link normalisation} {links} { + string equal [file normalize [file join dir.file linkinside.filefoo]] \ + [file normalize [file join dir.link inside.filefoo]] } {0} file delete -force link.file dir.link diff --git a/tests/winFile.test b/tests/winFile.test index 0cf76e2..c0b26e3 100644 --- a/tests/winFile.test +++ b/tests/winFile.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: winFile.test,v 1.7 2002/05/02 20:15:20 vincentdarley Exp $ +# RCS: @(#) $Id: winFile.test,v 1.8 2002/06/13 09:40:00 vincentdarley Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -65,10 +65,14 @@ test winFile-2.2 {TclpMatchFiles: case sensitivity} {pcOnly} { test winFile-3.1 {file system} {pcOnly} { set res "volume types ok" foreach vol [file volumes] { - if {![string equal [lindex [file system $vol] 1] [testvolumetype $vol]]} { - set res "For $vol, we found [file system $vol]\ - and [testvolumetype $vol] are different" - break + # Have to catch in case there is a removable drive (CDROM, floppy) + # with nothing in it. + catch { + if {![string equal [lindex [file system $vol] 1] [testvolumetype $vol]]} { + set res "For $vol, we found [file system $vol]\ + and [testvolumetype $vol] are different" + break + } } } set res diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c index cdd6697..9edd47e 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.22 2002/06/12 15:05:20 dkf Exp $ + * RCS: @(#) $Id: tclUnixFile.c,v 1.23 2002/06/13 09:40:01 vincentdarley Exp $ */ #include "tclInt.h" @@ -724,9 +724,10 @@ TclpObjStat(pathPtr, bufPtr) #ifdef S_IFLNK Tcl_Obj* -TclpObjLink(pathPtr, toPtr) +TclpObjLink(pathPtr, toPtr, linkType) Tcl_Obj *pathPtr; Tcl_Obj *toPtr; + int linkType; { extern Tcl_Filesystem nativeFilesystem; @@ -737,11 +738,14 @@ TclpObjLink(pathPtr, toPtr) if (src == NULL || target == NULL) { return NULL; } - if (symlink(src, target) != 0) { - 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; } else { - return toPtr; + if (symlink(src, target) != 0) return NULL; } + return toPtr; } else { Tcl_Obj* linkPtr = NULL; diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c index c17285e..e3e95e5 100644 --- a/win/tclWin32Dll.c +++ b/win/tclWin32Dll.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: tclWin32Dll.c,v 1.15 2002/03/15 01:10:19 mdejong Exp $ + * RCS: @(#) $Id: tclWin32Dll.c,v 1.16 2002/06/13 09:40:01 vincentdarley Exp $ */ #include "tclWinInt.h" @@ -84,6 +84,7 @@ static TclWinProcs asciiProcs = { (BOOL (WINAPI *)(CONST TCHAR *)) SetCurrentDirectoryA, (BOOL (WINAPI *)(CONST TCHAR *, DWORD)) SetFileAttributesA, NULL, + NULL, }; static TclWinProcs unicodeProcs = { @@ -122,6 +123,7 @@ static TclWinProcs unicodeProcs = { (BOOL (WINAPI *)(CONST TCHAR *)) SetCurrentDirectoryW, (BOOL (WINAPI *)(CONST TCHAR *, DWORD)) SetFileAttributesW, NULL, + NULL, }; TclWinProcs *tclWinProcs; @@ -467,6 +469,10 @@ TclWinSetInterfaces( tclWinProcs->getFileAttributesExProc = (BOOL (WINAPI *)(CONST TCHAR *, GET_FILEEX_INFO_LEVELS, LPVOID)) GetProcAddress(hInstance, "GetFileAttributesExW"); + tclWinProcs->createHardLinkProc = + (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR*, + LPSECURITY_ATTRIBUTES)) GetProcAddress(hInstance, + "CreateHardLinkW"); FreeLibrary(hInstance); } } @@ -479,6 +485,10 @@ TclWinSetInterfaces( tclWinProcs->getFileAttributesExProc = (BOOL (WINAPI *)(CONST TCHAR *, GET_FILEEX_INFO_LEVELS, LPVOID)) GetProcAddress(hInstance, "GetFileAttributesExA"); + tclWinProcs->createHardLinkProc = + (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR*, + LPSECURITY_ATTRIBUTES)) GetProcAddress(hInstance, + "CreateHardLinkA"); FreeLibrary(hInstance); } } diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 622be3c..6195c18 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.30 2002/06/12 19:16:01 hobbs Exp $ + * RCS: @(#) $Id: tclWinFile.c,v 1.31 2002/06/13 09:40:02 vincentdarley Exp $ */ //#define _WIN32_WINNT 0x0500 @@ -22,14 +22,14 @@ #include #include /* For TclpGetUserHome(). */ -extern int ConvertFileNameFormat(Tcl_Interp *interp, - int objIndex, Tcl_Obj *fileName, int longShort, - Tcl_Obj **attributePtrPtr); +extern int ConvertFileNameFormat(Tcl_Interp *interp, + int objIndex, Tcl_Obj *fileName, int longShort, + Tcl_Obj **attributePtrPtr); /* - * Declarations for 'link' related information (which may or may - * not be in the windows headers, and some of which is not very - * well documented). + * Declarations for 'link' related information. This information + * should come with VC++ 6.0, but is not in some older SDKs. + * In any case it is not well documented. */ #ifndef IO_REPARSE_TAG_RESERVED_ONE # define IO_REPARSE_TAG_RESERVED_ONE 0x000000001 @@ -90,6 +90,13 @@ extern int ConvertFileNameFormat(Tcl_Interp *interp, /* * Undocumented REPARSE_MOUNTPOINT_HEADER_SIZE structure definition. * This is found in winnt.h. + * + * IMPORTANT: caution when using this structure, since the actual + * structures used will want to store a full path in the 'PathBuffer' + * field, but there isn't room (there's only a single WCHAR!). Therefore + * one must artificially create a larger space of memory and then cast it + * to this type. We use the 'DUMMY_REPARSE_BUFFER' struct just below to + * deal with this problem. */ #define REPARSE_MOUNTPOINT_HEADER_SIZE 8 @@ -120,6 +127,11 @@ typedef struct _REPARSE_DATA_BUFFER { } REPARSE_DATA_BUFFER; #endif +typedef struct { + REPARSE_DATA_BUFFER dummy; + WCHAR dummyBuf[MAX_PATH*3]; +} DUMMY_REPARSE_BUFFER; + /* Other typedefs required by this code */ static time_t ToCTime(FILETIME fileTime); @@ -149,12 +161,86 @@ static int NativeMatchType(CONST char *name, int nameLen, 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); +static int WinSymLinkDirectory(CONST TCHAR* LinkDirectory, + CONST TCHAR* LinkTarget); extern Tcl_Filesystem nativeFilesystem; /* *-------------------------------------------------------------------- * + * WinLink + * + * Make a link from source to target. + *-------------------------------------------------------------------- + */ +static int +WinLink(LinkSource, LinkTarget, linkType) + CONST TCHAR* LinkSource; + CONST TCHAR* LinkTarget; + int linkType; +{ + WCHAR tempFileName[MAX_PATH]; + TCHAR* tempFilePart; + int attr; + + /* Get the full path referenced by the target */ + if (!(*tclWinProcs->getFullPathNameProc)(LinkTarget, + MAX_PATH, tempFileName, &tempFilePart)) { + /* Invalid file */ + TclWinConvertError(GetLastError()); + return -1; + } + + /* Make sure source file doesn't exist */ + attr = (*tclWinProcs->getFileAttributesProc)(LinkSource); + if (attr != 0xffffffff) { + Tcl_SetErrno(EEXIST); + return -1; + } + + /* Get the full path referenced by the directory */ + if (!(*tclWinProcs->getFullPathNameProc)(LinkSource, + MAX_PATH, tempFileName, &tempFilePart)) { + /* Invalid file */ + TclWinConvertError(GetLastError()); + return -1; + } + /* Check the target */ + attr = (*tclWinProcs->getFileAttributesProc)(LinkTarget); + if (attr == 0xffffffff) { + /* The target doesn't exist */ + TclWinConvertError(GetLastError()); + return -1; + } else if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) { + /* It is a file */ + if (tclWinProcs->createHardLinkProc == NULL) { + Tcl_SetErrno(ENOTDIR); + return -1; + } + if (linkType == 1) { + /* Can't symlink files */ + return -1; + } + if (!(*tclWinProcs->createHardLinkProc)(LinkSource, LinkTarget, NULL)) { + TclWinConvertError(GetLastError()); + return -1; + } + return 0; + } else { + if (linkType == 2) { + /* Can't hard link directories */ + return -1; + } + return WinSymLinkDirectory(LinkSource, LinkTarget); + } +} + +/* + *-------------------------------------------------------------------- + * * WinReadLink * * What does 'LinkSource' point to? We need the original 'pathPtr' @@ -195,6 +281,67 @@ WinReadLink(LinkSource) /* *-------------------------------------------------------------------- * + * WinSymLinkDirectory + * + * This routine creates a NTFS junction, using the undocumented + * FSCTL_SET_REPARSE_POINT structure Win2K uses for mount points + * and junctions. + * + * Assumption that LinkTarget is a valid, existing directory. + * + * Returns zero on success. + *-------------------------------------------------------------------- + */ +static int +WinSymLinkDirectory(LinkDirectory, LinkTarget) + CONST TCHAR* LinkDirectory; + CONST TCHAR* LinkTarget; +{ + DUMMY_REPARSE_BUFFER dummy; + REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER*)&dummy; + int len; + WCHAR nativeTarget[MAX_PATH]; + WCHAR *loop; + + /* Make the native target name */ + memcpy((VOID*)nativeTarget, (VOID*)L"\\??\\", 4*sizeof(WCHAR)); + memcpy((VOID*)(nativeTarget + 4), (VOID*)LinkTarget, + sizeof(WCHAR)*(1+wcslen((WCHAR*)LinkTarget))); + len = wcslen(nativeTarget); + /* + * We must have backslashes only. This is VERY IMPORTANT. + * If we have any forward slashes everything appears to work, + * but the resulting symlink is useless! + */ + for (loop = nativeTarget; *loop != 0; loop++) { + if (*loop == L'/') *loop = L'\\'; + } + if ((nativeTarget[len-1] == L'\\') && (nativeTarget[len-2] != L':')) { + nativeTarget[len-1] = 0; + } + + /* Build the reparse info */ + memset(reparseBuffer, 0, sizeof(DUMMY_REPARSE_BUFFER)); + reparseBuffer->ReparseTag = IO_REPARSE_TAG_MOUNT_POINT; + reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength = + wcslen(nativeTarget) * sizeof(WCHAR); + reparseBuffer->Reserved = 0; + reparseBuffer->SymbolicLinkReparseBuffer.PrintNameLength = 0; + reparseBuffer->SymbolicLinkReparseBuffer.PrintNameOffset = + reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength + + sizeof(WCHAR); + memcpy(reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer, nativeTarget, + sizeof(WCHAR) + + reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength); + reparseBuffer->ReparseDataLength = + reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength + 12; + + return NativeWriteReparse(LinkDirectory, reparseBuffer); +} + +/* + *-------------------------------------------------------------------- + * * TclWinSymLinkCopyDirectory * * Copy a Windows NTFS junction. This function assumes that @@ -209,12 +356,13 @@ TclWinSymLinkCopyDirectory(LinkOriginal, LinkCopy) CONST TCHAR* LinkOriginal; /* Existing junction - reparse point */ CONST TCHAR* LinkCopy; /* Will become a duplicate junction */ { + DUMMY_REPARSE_BUFFER dummy; + REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER*)&dummy; - REPARSE_DATA_BUFFER reparseBuffer; - if (NativeReadReparse(LinkOriginal, &reparseBuffer)) { + if (NativeReadReparse(LinkOriginal, reparseBuffer)) { return -1; } - return NativeWriteReparse(LinkCopy, &reparseBuffer); + return NativeWriteReparse(LinkCopy, reparseBuffer); } /* @@ -237,16 +385,17 @@ TclWinSymLinkDelete(LinkOriginal, linkOnly) int linkOnly; { /* It is a symbolic link -- remove it */ + DUMMY_REPARSE_BUFFER dummy; + REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER*)&dummy; HANDLE hFile; - REPARSE_DATA_BUFFER buffer; int returnedLength; - memset(&buffer, 0, sizeof( buffer )); - buffer.ReparseTag = IO_REPARSE_TAG_MOUNT_POINT; + memset(reparseBuffer, 0, sizeof(DUMMY_REPARSE_BUFFER)); + reparseBuffer->ReparseTag = IO_REPARSE_TAG_MOUNT_POINT; hFile = (*tclWinProcs->createFileProc)(LinkOriginal, GENERIC_WRITE, 0, NULL, OPEN_EXISTING, FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, NULL); if (hFile != INVALID_HANDLE_VALUE) { - if (!DeviceIoControl(hFile, FSCTL_DELETE_REPARSE_POINT, &buffer, + if (!DeviceIoControl(hFile, FSCTL_DELETE_REPARSE_POINT, reparseBuffer, REPARSE_MOUNTPOINT_HEADER_SIZE, NULL, 0, &returnedLength, NULL)) { /* Error setting junction */ @@ -282,18 +431,19 @@ WinReadLinkDirectory(LinkDirectory) CONST TCHAR* LinkDirectory; { int attr; - REPARSE_DATA_BUFFER reparseBuffer; + DUMMY_REPARSE_BUFFER dummy; + REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER*)&dummy; attr = (*tclWinProcs->getFileAttributesProc)(LinkDirectory); if (!(attr & FILE_ATTRIBUTE_REPARSE_POINT)) { Tcl_SetErrno(EINVAL); return NULL; } - if (NativeReadReparse(LinkDirectory, &reparseBuffer)) { + if (NativeReadReparse(LinkDirectory, reparseBuffer)) { return NULL; } - switch (reparseBuffer.ReparseTag) { + switch (reparseBuffer->ReparseTag) { case 0x80000000|IO_REPARSE_TAG_SYMBOLIC_LINK: case IO_REPARSE_TAG_SYMBOLIC_LINK: case IO_REPARSE_TAG_MOUNT_POINT: { @@ -301,12 +451,12 @@ WinReadLinkDirectory(LinkDirectory) ClientData clientData; Tcl_Obj *retVal; - len = reparseBuffer.SymbolicLinkReparseBuffer.SubstituteNameLength + len = reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength + sizeof(WCHAR); clientData = (ClientData)ckalloc(len); memcpy((VOID*)clientData, - (VOID*)reparseBuffer.SymbolicLinkReparseBuffer.PathBuffer, - len); + (VOID*)reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer, + len); retVal = Tcl_FSNewNativePath(&nativeFilesystem, clientData); Tcl_IncrRefCount(retVal); @@ -347,8 +497,8 @@ NativeReadReparse(LinkDirectory, buffer) } /* Get the link */ if (!DeviceIoControl(hFile, FSCTL_GET_REPARSE_POINT, NULL, - 0, buffer, - sizeof(REPARSE_DATA_BUFFER), &returnedLength, NULL)) { + 0, buffer, sizeof(DUMMY_REPARSE_BUFFER), + &returnedLength, NULL)) { /* Error setting junction */ TclWinConvertError(GetLastError()); CloseHandle(hFile); @@ -1705,12 +1855,26 @@ TclpObjLstat(pathPtr, statPtr) #ifdef S_IFLNK Tcl_Obj* -TclpObjLink(pathPtr, toPtr) +TclpObjLink(pathPtr, toPtr, linkType) Tcl_Obj *pathPtr; Tcl_Obj *toPtr; + int linkType; { if (toPtr != NULL) { - return NULL; + int res; + TCHAR* LinkTarget = (TCHAR*)Tcl_FSGetNativePath(toPtr); + TCHAR* LinkSource = (TCHAR*)Tcl_FSGetNativePath(pathPtr); + 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); + if (res == 0) { + return toPtr; + } else { + return NULL; + } } else { TCHAR* LinkSource = (TCHAR*)Tcl_FSGetNativePath(pathPtr); if (LinkSource == NULL) { diff --git a/win/tclWinInt.h b/win/tclWinInt.h index 1508e56..eb89c35 100644 --- a/win/tclWinInt.h +++ b/win/tclWinInt.h @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclWinInt.h,v 1.15 2002/06/12 09:28:59 vincentdarley Exp $ + * RCS: @(#) $Id: tclWinInt.h,v 1.16 2002/06/13 09:40:02 vincentdarley Exp $ */ #ifndef _TCLWININT @@ -91,6 +91,8 @@ typedef struct TclWinProcs { BOOL (WINAPI *setFileAttributesProc)(CONST TCHAR *, DWORD); BOOL (WINAPI *getFileAttributesExProc)(CONST TCHAR *, GET_FILEEX_INFO_LEVELS, LPVOID); + BOOL (WINAPI *createHardLinkProc)(CONST TCHAR*, CONST TCHAR*, + LPSECURITY_ATTRIBUTES); } TclWinProcs; EXTERN TclWinProcs *tclWinProcs; -- cgit v0.12