diff options
| -rw-r--r-- | ChangeLog | 8 | ||||
| -rw-r--r-- | doc/FileSystem.3 | 23 | ||||
| -rw-r--r-- | generic/tclPathObj.c | 31 | ||||
| -rw-r--r-- | tests/cmdAH.test | 14 |
4 files changed, 65 insertions, 11 deletions
@@ -1,3 +1,11 @@ +2004-05-17 Vince Darley <vincentdarley@users.sourceforge.net> + + * generic/tclPathObj.c: fix to (Bug 956063) in 'file dirname'. + * tests/cmdAH.test: added test for this bug. + + * doc/FileSystem.3: better documentation of refCount requirements + of some FS functions (Bug 956126) + 2004-05-19 Donal K. Fellows <donal.k.fellows@man.ac.uk> * generic/tclTest.c (TestgetintCmd): Made the tests in get.test check diff --git a/doc/FileSystem.3 b/doc/FileSystem.3 index 74cdf01..0162c4d 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.42 2004/04/23 12:09:37 vincentdarley Exp $ +'\" RCS: @(#) $Id: FileSystem.3,v 1.43 2004/05/19 16:56:39 vincentdarley Exp $ '\" .so man.macros .TH Filesystem 3 8.4 Tcl "Tcl Library Procedures" @@ -503,7 +503,14 @@ The separator is returned as a Tcl_Obj containing a string of length \fBTcl_FSJoinPath\fR takes the given Tcl_Obj, which must be a valid list (which is allowed to have a refCount of zero), and returns the path object given by considering the first 'elements' elements as valid path -segments. If elements < 0, we use the entire list. +segments (each path segment may be a complete path, a partial path or +just a single possible directory or file name). If any path segment is +actually an absolute path, then all prior path segments are discarded. +If elements < 0, we use the entire list. +.PP +It is possible that the returned object is actually an element +of the given list, so the caller should be careful to store a +refCount to it before freeing the list. .PP Returns object, typically with refCount of zero (but it could be shared under some conditions) , containing the joined path. The caller must @@ -1118,11 +1125,13 @@ typedef Tcl_Obj* Tcl_FSLinkProc( 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 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. See +not be read. The result is owned by the caller (and should therefore +have its ref count incremented before being returned). Any callers +should call Tcl_DecrRefCount on this result when it 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 +(i.e. no ref count manipulation on either end is needed). See the documentation for \fBTcl_FSLink\fR for the correct interpretation of the \fIlinkAction\fR flags. .SH LISTVOLUMESPROC diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index bcb1500..df9963a 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.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: tclPathObj.c,v 1.30 2004/04/23 12:09:37 vincentdarley Exp $ + * RCS: @(#) $Id: tclPathObj.c,v 1.31 2004/05/19 16:56:39 vincentdarley Exp $ */ #include "tclInt.h" @@ -494,6 +494,26 @@ TclPathPart(interp, pathPtr, portion) if (PATHFLAGS(pathPtr) != 0) { switch (portion) { case TCL_PATH_DIRNAME: { + /* + * Check if the joined-on bit has any directory + * delimiters in it. If so, the 'dirname' would + * be a joining of the main part with the dirname + * of the joined-on bit. We could handle that + * special case here, but we don't, and instead + * just use the standardPath code. + */ + CONST char *rest = Tcl_GetString(fsPathPtr->normPathPtr); + if (strchr(rest, '/') != NULL) { + goto standardPath; + } + if ((tclPlatform == TCL_PLATFORM_WINDOWS) + && (strchr(rest, '\\') != NULL)) { + goto standardPath; + } + /* + * The joined-on path is simple, so we can just + * return here. + */ Tcl_IncrRefCount(fsPathPtr->cwdPtr); return fsPathPtr->cwdPtr; } @@ -662,8 +682,13 @@ GetExtension(pathPtr) * * This function takes the given Tcl_Obj, which should be a valid * list, and returns the path object given by considering the - * first 'elements' elements as valid path segments. If elements < 0, - * we use the entire list. + * first 'elements' elements as valid path segments (each path + * segment may be a complete path, a partial path or just a single + * possible directory or file name). If any path segment is + * actually an absolute path, then all prior path segments are + * discarded. + * + * If elements < 0, we use the entire list that was given. * * It is possible that the returned object is actually an element * of the given list, so the caller should be careful to store a diff --git a/tests/cmdAH.test b/tests/cmdAH.test index c66fc82..41fef8d 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.40 2004/05/17 10:38:22 vincentdarley Exp $ +# RCS: @(#) $Id: cmdAH.test,v 1.41 2004/05/19 16:56:40 vincentdarley Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 @@ -367,6 +367,18 @@ test cmdAH-8.45 {Tcl_FileObjCmd: dirname} testsetplatform { set env(HOME) $temp set result } {0 /homewontexist} +test cmdAH-8.46 {Tcl_FileObjCmd: dirname} { + set f [file normalize [info nameof]] + file exists $f + set res1 [file dirname [file join $f foo/bar]] + set res2 [file dirname "${f}/foo/bar"] + if {$res1 eq $res2} { + set res "ok" + } else { + set res "file dirname problem, $res1, $res2 not equal" + } + set res +} {ok} # tail |