summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorvincentdarley <vincentdarley>2004-05-19 16:56:35 (GMT)
committervincentdarley <vincentdarley>2004-05-19 16:56:35 (GMT)
commite8f6e134d9fe78331b2ee9696941ad0d20683403 (patch)
tree94dde45090003bf42f08259bde76226467fb2e62
parent645435663a5c2ba8dcdc3be20f50410cae48a629 (diff)
downloadtcl-e8f6e134d9fe78331b2ee9696941ad0d20683403.zip
tcl-e8f6e134d9fe78331b2ee9696941ad0d20683403.tar.gz
tcl-e8f6e134d9fe78331b2ee9696941ad0d20683403.tar.bz2
fix to 'file dirname' and to fs refCount documentation
-rw-r--r--ChangeLog8
-rw-r--r--doc/FileSystem.323
-rw-r--r--generic/tclPathObj.c31
-rw-r--r--tests/cmdAH.test14
4 files changed, 65 insertions, 11 deletions
diff --git a/ChangeLog b/ChangeLog
index 9c28462..5a3b426 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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