From ef6b0cfeabedafe5027e2a6ff6ca26d6f3c7d07a Mon Sep 17 00:00:00 2001
From: vincentdarley <vincentdarley>
Date: Thu, 2 Dec 2004 18:48:12 +0000
Subject: filesystem, glob, tilde fix

---
 ChangeLog             |  6 ++++++
 generic/tclIOUtil.c   | 30 +++++++++++++++++++++++++----
 tests/fileSystem.test | 52 +++++++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 84 insertions(+), 4 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index d10ce51..e7f8a75 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2004-12-02  Vince Darley  <vincentdarley@users.sourceforge.net>
+
+	* generic/tclIOUtil.c: fix and new tests for [Bug 1074671] to
+	* tests/fileSystem.test:   ensure tilde paths are not returned
+	specially by 'glob'.
+
 2004-12-01  Don Porter  <dgp@users.sourceforge.net>
 
 	* library/auto.tcl (tcl_findLibrary):	Disabled use of [file normalize]
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index 3b0ed7c..07ad92c 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.19 2004/11/23 15:23:13 vincentdarley Exp $
+ * RCS: @(#) $Id: tclIOUtil.c,v 1.77.2.20 2004/12/02 18:48:14 vincentdarley Exp $
  */
 
 #include "tclInt.h"
@@ -5050,11 +5050,23 @@ TclNewFSPathObj(Tcl_Obj *dirPtr, CONST char *addStrRep, int len)
  *
  * TclFSMakePathRelative --
  *
- *      Like SetFsPathFromAny, but assumes the given object is an
- *      absolute normalized path. Only for internal use.
+ *      Only for internal use.
+ *      
+ *      Takes a path and a directory, where we _assume_ both path and
+ *      directory are absolute, normalized and that the path lies
+ *      inside the directory.  Returns a Tcl_Obj representing filename 
+ *      of the path relative to the directory.
+ *      
+ *      In the case where the resulting path would start with a '~', we
+ *      take special care to return an ordinary string.  This means to
+ *      use that path (and not have it interpreted as a user name),
+ *      one must prepend './'.  This may seem strange, but that is how
+ *      'glob' is currently defined.
  *      
  * Results:
- *      Standard Tcl error code.
+ *      NULL on error, otherwise a valid object, typically with
+ *      refCount of zero, which it is assumed the caller will
+ *      increment.
  *
  * Side effects:
  *	The old representation may be freed, and new memory allocated.
@@ -5094,6 +5106,16 @@ TclFSMakePathRelative(interp, objPtr, cwdPtr)
 		    (*objPtr->typePtr->freeIntRepProc)(objPtr);
 		}
 	    }
+	    /* Now objPtr is a string object */
+	    
+	    if (Tcl_GetString(objPtr)[0] == '~') {
+		/* 
+		 * If the first character of the path is a tilde,
+		 * we must just return the path as is, to agree
+		 * with the defined behaviour of 'glob'.
+		 */
+		return objPtr;
+	    }
 
 	    fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath));
 
diff --git a/tests/fileSystem.test b/tests/fileSystem.test
index 20c04ae..f42e776 100644
--- a/tests/fileSystem.test
+++ b/tests/fileSystem.test
@@ -563,6 +563,58 @@ test filesystem-9.6 {path objects and file join and object rep} {winOnly} {
     lappend res [file join $p toto]
 } {C:/toto/toto C:/toto/toto}
 
+test filesystem-9.7 {path objects and glob and file tail and tilde} {
+    set res {}
+    set origdir [pwd]
+    cd [tcltest::temporaryDirectory]
+    file mkdir tilde
+    close [open tilde/~testNotExist w]
+    cd tilde
+    set file [lindex [glob *test*] 0]
+    lappend res [file exists $file] [catch {file tail $file} r] $r
+    lappend res $file
+    lappend res [file exists $file] [catch {file tail $file} r] $r
+    lappend res [catch {file tail $file} r] $r
+    cd ..
+    file delete -force tilde
+    cd $origdir
+    set res
+} {0 1 {user "testNotExist" doesn't exist} ~testNotExist 0 1 {user "testNotExist" doesn't exist} 1 {user "testNotExist" doesn't exist}}
+test filesystem-9.8 {path objects and glob and file tail and tilde} {
+    set res {}
+    set origdir [pwd]
+    cd [tcltest::temporaryDirectory]
+    file mkdir tilde
+    close [open tilde/~testNotExist w]
+    cd tilde
+    set file1 [lindex [glob *test*] 0]
+    set file2 "~testNotExist"
+    lappend res $file1 $file2
+    lappend res [catch {file tail $file1} r] $r
+    lappend res [catch {file tail $file2} r] $r
+    cd ..
+    file delete -force tilde
+    cd $origdir
+    set res
+} {~testNotExist ~testNotExist 1 {user "testNotExist" doesn't exist} 1 {user "testNotExist" doesn't exist}}
+test filesystem-9.9 {path objects and glob and file tail and tilde} {
+    set res {}
+    set origdir [pwd]
+    cd [tcltest::temporaryDirectory]
+    file mkdir tilde
+    close [open tilde/~testNotExist w]
+    cd tilde
+    set file1 [lindex [glob *test*] 0]
+    set file2 "~testNotExist"
+    lappend res [catch {file exists $file1} r] $r
+    lappend res [catch {file exists $file2} r] $r
+    lappend res [string equal $file1 $file2]
+    cd ..
+    file delete -force tilde
+    cd $origdir
+    set res
+} {0 0 0 0 1}
+
 cleanupTests
 }
 namespace delete ::tcl::test::fileSystem
-- 
cgit v0.12