glob -l on broken symlink fix

4 files changed, 68 insertions, 9 deletions

diff --git a/ChangeLog b/ChangeLog
index 711dfb3..3717c41 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2003-02-10  Vince Darley  <vincentdarley@users.sourceforge.net>
+
+	* tests/fileName.test:
+	* unix/tclUnixFile.c: fix for [Bug 685445] when using 'glob -l'
+	on broken symbolic links.  Added two new tests for this bug.
+
 2003-02-11  Kevin Kenny  <kennykb@users.sourceforge.net>
 
 	* tests/http.test: Corrected a problem where http-4.14 would fail
diff --git a/tests/fCmd.test b/tests/fCmd.test
index 08ff618..e3bec24 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.25 2002/10/04 08:25:14 dkf Exp $
+# RCS: @(#) $Id: fCmd.test,v 1.26 2003/02/12 19:18:13 vincentdarley Exp $
 #
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
@@ -69,11 +69,11 @@ proc openup {path} {
 }
 
 proc cleanup {args} {
-	if {$::tcl_platform(platform) == "macintosh"} {
-		set wd [list :]
-	} else {
-		set wd [list .]
-	}
+    if {$::tcl_platform(platform) == "macintosh"} {
+	set wd [list :]
+    } else {
+	set wd [list .]
+    }
     foreach p [concat $wd $args] {
 	set x ""
 	catch {
diff --git a/tests/fileName.test b/tests/fileName.test
index 15bef4e..01b67ef 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.29 2003/02/07 15:29:31 vincentdarley Exp $
+# RCS: @(#) $Id: fileName.test,v 1.30 2003/02/12 18:57:51 vincentdarley Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -1185,6 +1185,11 @@ if {[string equal $tcl_platform(platform) "windows"]} {
 } else {
     tcltest::testConstraint linkDirectory 1
 }
+if {[string equal $tcl_platform(platform) "windows"]} {
+    tcltest::testConstraint symbolicLinkFile 0
+} else {
+    tcltest::testConstraint symbolicLinkFile 1
+}
 test filename-11.17.2 {Tcl_GlobCmd} {notRoot linkDirectory} {
     set dir [pwd]
     set ret "error in test"
@@ -1247,6 +1252,42 @@ test filename-11.17.6 {Tcl_GlobCmd} {
     list [catch {lsort [glob -directory $globname -tails *.c *.c]} msg] $msg
 } [list 0 [lsort [concat [list "weird name.c" x,z1.c x1.c y1.c z1.c] \
   [list "weird name.c" x,z1.c x1.c y1.c z1.c]]]]
+test filename-11.17.7 {Tcl_GlobCmd: broken link and glob -l} {linkDirectory} {
+    set dir [pwd]
+    set ret "error in test"
+    if {[catch {
+	cd $globname
+	file mkdir nonexistent
+	file link -symbolic link nonexistent
+	file delete nonexistent
+	cd $dir
+	set ret [list [catch {
+	    lsort [glob -nocomplain -directory $globname -type l *]
+	} msg] $msg]
+    }]} {
+	cd $dir
+    }
+    file delete [file join $globname link]
+    set ret
+} [list 0 [list [file join $globname link]]]
+test filename-11.17.8 {Tcl_GlobCmd: broken link and glob -l} {symbolicLinkFile} {
+    set dir [pwd]
+    set ret "error in test"
+    if {[catch {
+	cd $globname
+	close [open "nonexistent" w]
+	file link -symbolic link nonexistent
+	file delete nonexistent
+	cd $dir
+	set ret [list [catch {
+	    lsort [glob -nocomplain -directory $globname -type l *]
+	} msg] $msg]
+    }]} {
+	cd $dir
+    }
+    file delete [file join $globname link]
+    set ret
+} [list 0 [list [file join $globname link]]]
 test filename-11.18 {Tcl_GlobCmd} {unixOnly} {
     list [catch {lsort [glob -path $globname/ *]} msg] $msg
 } [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\
diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c
index 4e89ee1..3e74d16 100644
--- a/unix/tclUnixFile.c
+++ b/unix/tclUnixFile.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: tclUnixFile.c,v 1.31 2003/02/11 09:42:02 hobbs Exp $
+ * RCS: @(#) $Id: tclUnixFile.c,v 1.32 2003/02/12 18:57:52 vincentdarley Exp $
  */
 
 #include "tclInt.h"
@@ -386,7 +386,19 @@ NativeMatchType(
 	    if (types->perm == 0) {
 		/* We haven't yet done a stat on the file */
 		if (TclOSstat(nativeEntry, &buf) != 0) {
-		    /* Posix error occurred */
+		    /* 
+		     * Posix error occurred.  The only ok
+		     * case is if this is a link to a nonexistent
+		     * file, and the user did 'glob -l'. So
+		     * we check that here:
+		     */
+		    if (types->type & TCL_GLOB_TYPE_LINK) {
+			if (TclOSlstat(nativeEntry, &buf) == 0) {
+			    if (S_ISLNK(buf.st_mode)) {
+				return 1;
+			    }
+			}
+		    }
 		    return 0;
 		}
 	    }