From 667a4aad934603ef865cba2b5b15f4c5687dc0c4 Mon Sep 17 00:00:00 2001
From: vincentdarley <vincentdarley>
Date: Mon, 6 Oct 2003 09:49:19 +0000
Subject: filesystem bug fixes: volumerelative normalization, file join
inconsistency
---
ChangeLog | 6 ++++
generic/tclFileName.c | 5 +--
generic/tclIOUtil.c | 92 ++++++++++++++++++++++++++++++++-------------------
tests/fileName.test | 19 ++++++++++-
4 files changed, 85 insertions(+), 37 deletions(-)
diff --git a/ChangeLog b/ChangeLog
index 71beb68..460690c 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2003-10-06 Vince Darley <vincentdarley@users.sourceforge.net>
+
+ * generic/tclFileName.c:
+ * generic/tclIOUtil.c: backport of volumerelative file normalization
+ and 'file join' inconsistency fixes [Bug 767834, 813273].
+
2003-10-04 Chengye Mao <chengye.geo@yahoo.com>
* win/tclWinPipe.c: fixed a bug in BuildCommandLine.
diff --git a/generic/tclFileName.c b/generic/tclFileName.c
index be689af..6d7a41c 100644
--- a/generic/tclFileName.c
+++ b/generic/tclFileName.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: tclFileName.c,v 1.40.2.4 2003/10/03 17:45:37 vincentdarley Exp $
+ * RCS: @(#) $Id: tclFileName.c,v 1.40.2.5 2003/10/06 09:49:19 vincentdarley Exp $
*/
#include "tclInt.h"
@@ -1392,7 +1392,8 @@ Tcl_TranslateFileName(interp, name, bufferPtr)
Tcl_DStringInit(bufferPtr);
Tcl_DStringAppend(bufferPtr, Tcl_GetString(transPtr), -1);
Tcl_DecrRefCount(path);
-
+ Tcl_DecrRefCount(transPtr);
+
/*
* Convert forward slashes to backslashes in Windows paths because
* some system interfaces don't accept forward slashes.
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index c59348a..8de62f1 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.77.2.9 2003/10/03 17:45:37 vincentdarley Exp $
+ * RCS: @(#) $Id: tclIOUtil.c,v 1.77.2.10 2003/10/06 09:49:20 vincentdarley Exp $
*/
#include "tclInt.h"
@@ -4515,25 +4515,34 @@ Tcl_FSJoinPath(listObj, elements)
}
}
- if (elements == 2) {
- /*
- * This is a special case where we can be much more
- * efficient
- */
- Tcl_Obj *base;
+ res = Tcl_NewObj();
+
+ for (i = 0; i < elements; i++) {
+ Tcl_Obj *elt;
+ int driveNameLength;
+ Tcl_PathType type;
+ char *strElt;
+ int strEltLen;
+ int length;
+ char *ptr;
+ Tcl_Obj *driveName = NULL;
+
+ Tcl_ListObjIndex(NULL, listObj, i, &elt);
- Tcl_ListObjIndex(NULL, listObj, 0, &base);
/*
- * There is only any value in doing this if the first object is
- * of path type, otherwise we'll never actually get any
- * efficiency benefit elsewhere in the code (from re-using the
- * normalized representation of the base object).
+ * This is a special case where we can be much more
+ * efficient, where we are joining a single relative path
+ * onto an object that is already of path type. The
+ * 'TclNewFSPathObj' call below creates an object which
+ * can be normalized more efficiently. Currently we only
+ * use the special case when we have exactly two elements,
+ * but we could expand that in the future.
*/
- if (base->typePtr == &tclFsPathType
- && !(base->bytes != NULL && base->bytes[0] == '\0')) {
+ if ((i == (elements-2)) && (i == 0) && (elt->typePtr == &tclFsPathType)
+ && !(elt->bytes != NULL && (elt->bytes[0] == '\0'))) {
Tcl_Obj *tail;
Tcl_PathType type;
- Tcl_ListObjIndex(NULL, listObj, 1, &tail);
+ Tcl_ListObjIndex(NULL, listObj, i+1, &tail);
type = GetPathType(tail, NULL, NULL, NULL);
if (type == TCL_PATH_RELATIVE) {
CONST char *str;
@@ -4545,10 +4554,22 @@ Tcl_FSJoinPath(listObj, elements)
* '/'. There's no need to return a special path
* object, when the base itself is just fine!
*/
- return base;
+ Tcl_DecrRefCount(res);
+ return elt;
}
- if (str[0] != '.') {
- return TclNewFSPathObj(base, str, len);
+ /*
+ * If it doesn't begin with '.' and is a mac or unix
+ * path or it a windows path without backslashes, then we
+ * can be very efficient here. (In fact even a windows
+ * path with backslashes can be joined efficiently, but
+ * the path object would not have forward slashes only,
+ * and this would therefore contradict our 'file join'
+ * documentation).
+ */
+ if (str[0] != '.' && ((tclPlatform != TCL_PLATFORM_WINDOWS)
+ || (strchr(str, '\\') == NULL))) {
+ Tcl_DecrRefCount(res);
+ return TclNewFSPathObj(elt, str, len);
}
/*
* Otherwise we don't have an easy join, and
@@ -4556,24 +4577,27 @@ Tcl_FSJoinPath(listObj, elements)
* things
*/
} else {
- return tail;
+ if (tclPlatform == TCL_PLATFORM_UNIX) {
+ Tcl_DecrRefCount(res);
+ return tail;
+ } else {
+ CONST char *str;
+ int len;
+ str = Tcl_GetStringFromObj(tail,&len);
+ if (tclPlatform == TCL_PLATFORM_WINDOWS) {
+ if (strchr(str, '\\') == NULL) {
+ Tcl_DecrRefCount(res);
+ return tail;
+ }
+ } else if (tclPlatform == TCL_PLATFORM_MAC) {
+ if (strchr(str, '/') == NULL) {
+ Tcl_DecrRefCount(res);
+ return tail;
+ }
+ }
+ }
}
}
- }
-
- res = Tcl_NewObj();
-
- for (i = 0; i < elements; i++) {
- Tcl_Obj *elt;
- int driveNameLength;
- Tcl_PathType type;
- char *strElt;
- int strEltLen;
- int length;
- char *ptr;
- Tcl_Obj *driveName = NULL;
-
- Tcl_ListObjIndex(NULL, listObj, i, &elt);
strElt = Tcl_GetStringFromObj(elt, &strEltLen);
type = GetPathType(elt, &fsPtr, &driveNameLength, &driveName);
if (type != TCL_PATH_RELATIVE) {
diff --git a/tests/fileName.test b/tests/fileName.test
index e858caa..830618b 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.30.2.2 2003/10/03 17:25:22 vincentdarley Exp $
+# RCS: @(#) $Id: fileName.test,v 1.30.2.3 2003/10/06 09:49:20 vincentdarley Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -903,6 +903,23 @@ test filename-9.19 {Tcl_JoinPath: win} {testsetplatform} {
[file join C:/blah {C:\foo\bar}] \
[file join C:/blah C:/blah {C:\foo\bar}]
} {C:/foo/bar C:/foo/bar C:/foo/bar}
+test filename-9.19.1 {Tcl_JoinPath: win} {testsetplatform} {
+ testsetplatform win
+ set res {}
+ lappend res \
+ [file join {foo\bar}] \
+ [file join C:/blah {foo\bar}] \
+ [file join C:/blah C:/blah {foo\bar}]
+} {foo/bar C:/blah/foo/bar C:/blah/foo/bar}
+test filename-9.19.2 {Tcl_JoinPath: win} {testsetplatform winOnly} {
+ testsetplatform win
+ set res {}
+ lappend res \
+ [file join {foo\bar}] \
+ [file join [pwd] {foo\bar}] \
+ [file join [pwd] [pwd] {foo\bar}]
+ string map [list [pwd] pwd] $res
+} {foo/bar pwd/foo/bar pwd/foo/bar}
test filename-9.20 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
set res {}
--
cgit v0.12