diff options
| -rw-r--r-- | ChangeLog | 12 | ||||
| -rw-r--r-- | generic/tclFCmd.c | 56 | ||||
| -rw-r--r-- | tests/fCmd.test | 25 | ||||
| -rw-r--r-- | tests/unixFCmd.test | 5 |
4 files changed, 81 insertions, 17 deletions
@@ -1,3 +1,15 @@ +2002-08-08 Jeff Hobbs <jeffh@ActiveState.com> + + * tests/fCmd.test: + * tests/unixFCmd.test: updated tests for new link copy behavior. + * generic/tclFCmd.c (CopyRenameOneFile): changed the behavior to + follow links to endpoints and copy that file/directory instead of + just copying the surface link. This means that trying to copy a + link that has no endpoint (danling link) is an error. + [Patch #591647] (darley) + + * tests/README: slight wording improvements + 2002-08-07 Miguel Sofer <msofer@users.sourceforge.net> * docs/BoolObj.3: added description of valid string reps for a diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index e027977..743fe14 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.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: tclFCmd.c,v 1.18 2002/07/18 16:17:48 vincentdarley Exp $ + * RCS: @(#) $Id: tclFCmd.c,v 1.19 2002/08/08 08:56:21 hobbs Exp $ */ #include "tclInt.h" @@ -448,6 +448,8 @@ CopyRenameOneFile(interp, source, target, copyFlag, force) { int result; Tcl_Obj *errfile, *errorBuffer; + /* If source is a link, then this is the real file/directory */ + Tcl_Obj *actualSource = NULL; Tcl_StatBuf sourceStatBuf, targetStatBuf; if (Tcl_FSConvertToPathType(interp, source) != TCL_OK) { @@ -549,8 +551,53 @@ CopyRenameOneFile(interp, source, target, copyFlag, force) */ } + actualSource = source; + Tcl_IncrRefCount(actualSource); +#ifdef S_ISLNK + /* + * To add a flag to make 'copy' copy links instead of files, we could + * add a condition to ignore this 'if' here. + */ + if (copyFlag && S_ISLNK(sourceStatBuf.st_mode)) { + /* + * We want to copy files not links. Therefore we must follow the + * link. There are two purposes to this 'stat' call here. First + * we want to know if the linked-file/dir actually exists, and + * second, in the block of code which follows, some 20 lines + * down, we want to check if the thing is a file or directory. + */ + if (Tcl_FSStat(source, &sourceStatBuf) != 0) { + /* Actual file doesn't exist */ + Tcl_AppendResult(interp, + "error copying \"", Tcl_GetString(source), + "\": the target of this link doesn't exist", + (char *) NULL); + goto done; + } else { + int counter = 0; + while (1) { + Tcl_Obj *path = Tcl_FSLink(actualSource,NULL,0); + if (path == NULL) { + break; + } + Tcl_DecrRefCount(actualSource); + actualSource = path; + counter++; + /* Arbitrary limit of 20 links to follow */ + if (counter > 20) { + /* Too many links */ + Tcl_SetErrno(EMLINK); + errfile = source; + goto done; + } + } + /* Now 'actualSource' is the correct file */ + } + } +#endif + if (S_ISDIR(sourceStatBuf.st_mode)) { - result = Tcl_FSCopyDirectory(source, target, &errorBuffer); + result = Tcl_FSCopyDirectory(actualSource, target, &errorBuffer); if (result != TCL_OK) { if (errno == EXDEV) { /* @@ -598,7 +645,7 @@ CopyRenameOneFile(interp, source, target, copyFlag, force) } } } else { - result = Tcl_FSCopyFile(source, target); + result = Tcl_FSCopyFile(actualSource, target); if ((result != TCL_OK) && (errno == EXDEV)) { result = TclCrossFilesystemCopy(interp, source, target); } @@ -652,6 +699,9 @@ CopyRenameOneFile(interp, source, target, copyFlag, force) if (errorBuffer != NULL) { Tcl_DecrRefCount(errorBuffer); } + if (actualSource != NULL) { + Tcl_DecrRefCount(actualSource); + } return result; } diff --git a/tests/fCmd.test b/tests/fCmd.test index ee9e7a0..cca7d0c 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.21 2002/07/18 16:39:50 vincentdarley Exp $ +# RCS: @(#) $Id: fCmd.test,v 1.22 2002/08/08 08:56:21 hobbs Exp $ # if {[lsearch [namespace children] ::tcltest] == -1} { @@ -1889,21 +1889,20 @@ test fCmd-21.7 {TclCopyFilesCmd: copy a dangling link} {unixOnly notRoot} { file mkdir tfad1 file link -symbolic tfalink tfad1 file delete tfad1 - file copy tfalink tfalink2 - set result [string match [file type tfalink2] link] - file delete tfalink tfalink2 + set result [list [catch {file copy tfalink tfalink2} msg] $msg] + file delete -force tfalink tfalink2 set result -} {1} +} {1 {error copying "tfalink": the target of this link doesn't exist}} test fCmd-21.8 {TclCopyFilesCmd : copy a link } {unixOnly notRoot} { file mkdir tfad1 file link -symbolic tfalink tfad1 file copy tfalink tfalink2 - set r1 [file type tfalink] - set r2 [file type tfalink2] - set r3 [file isdir tfad1] - set result [expr {("$r1" == "link" ) && ("$r2" == "link" ) && $r3}] - file delete tfad1 tfalink tfalink2 + set r1 [file type tfalink]; # link + set r2 [file type tfalink2]; # directory + set r3 [file isdir tfad1]; # 1 + set result [expr {("$r1" == "link") && ("$r2" == "directory") && $r3}] + file delete -force tfad1 tfalink tfalink2 set result } {1} @@ -2300,10 +2299,12 @@ test fCmd-28.15 {file link: copies link not dir} {linkDirectory} { file delete -force abc.link file link abc.link abc.dir file copy abc.link abc2.link - set res [list [file type abc2.link] [file tail [file link abc2.link]]] + # abc2.linkdir was a copy of a link to a dir, so it should end up as + # a directory, not a link (links trace to endpoint). + set res [list [file type abc2.link] [file tail [file link abc.link]]] cd [workingDirectory] set res -} {link abc.dir} +} {directory abc.dir} cd [temporaryDirectory] file delete -force abc.link diff --git a/tests/unixFCmd.test b/tests/unixFCmd.test index 23e8752..408fe1e 100644 --- a/tests/unixFCmd.test +++ b/tests/unixFCmd.test @@ -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: unixFCmd.test,v 1.14 2002/07/10 13:08:20 dkf Exp $ +# RCS: @(#) $Id: unixFCmd.test,v 1.15 2002/08/08 08:56:21 hobbs Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -128,12 +128,13 @@ test unixFCmd-2.1 {TclpCopyFile: target exists: lstat(dst) == 0} \ file copy -force tf1 tf2 } {} test unixFCmd-2.2 {TclpCopyFile: src is symlink} {unixOnly notRoot} { + # copying links should end up with real files cleanup close [open tf1 a] file link -symbolic tf2 tf1 file copy tf2 tf3 file type tf3 -} {link} +} {file} test unixFCmd-2.3 {TclpCopyFile: src is block} {unixOnly notRoot} { cleanup set null "/dev/null" |