glob fixes

3 files changed, 86 insertions, 31 deletions

diff --git a/ChangeLog b/ChangeLog
index 7b3e809..10ad308 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,11 @@
+2002-05-30  Vince Darley  <vincentdarley@users.sourceforge.net>
+
+	* generic/tclFileName.c (TclGlob): fix to longstanding
+	'knownBug' in fileName tests 15.2-15.4, and fix to a new
+	Tcl 8.4 bug in certain uses of 'glob -tails'.
+	* tests/fileName.test: removed 'knownBug' flag from some tests,
+	added some new tests for above bugs.
+	
 2002-05-29  Jeff Hobbs  <jeffh@ActiveState.com>
 
 	* unix/configure: regen'ed
diff --git a/generic/tclFileName.c b/generic/tclFileName.c
index 8fc794b..e7dedf0 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.35 2002/05/07 18:03:04 vincentdarley Exp $
+ * RCS: @(#) $Id: tclFileName.c,v 1.36 2002/05/30 09:27:11 vincentdarley Exp $
  */
 
 #include "tclInt.h"
@@ -1925,13 +1925,21 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv)
  *	This procedure prepares arguments for the TclDoGlob call.
  *	It sets the separator string based on the platform, performs
  *      tilde substitution, and calls TclDoGlob.
+ *      
+ *      The interpreter's result, on entry to this function, must
+ *      be a valid Tcl list (e.g. it could be empty), since we will
+ *      lappend any new results to that list.  If it is not a valid
+ *      list, this function will fail to do anything very meaningful.
  *
  * Results:
  *	The return value is a standard Tcl result indicating whether
  *	an error occurred in globbing.  After a normal return the
  *	result in interp (set by TclDoGlob) holds all of the file names
  *	given by the pattern and unquotedPrefix arguments.  After an 
- *	error the result in interp will hold an error message.
+ *	error the result in interp will hold an error message, unless
+ *	the 'TCL_GLOBMODE_NO_COMPLAIN' flag was given, in which case
+ *	an error results in a TCL_OK return leaving the interpreter's
+ *	result unmodified.
  *
  * Side effects:
  *	The 'pattern' is written to.
@@ -1958,6 +1966,7 @@ TclGlob(interp, pattern, unquotedPrefix, globFlags, types)
     char c;
     int result, prefixLen;
     Tcl_DString buffer;
+    Tcl_Obj *oldResult;
 
     separators = NULL;		/* lint. */
     switch (tclPlatform) {
@@ -2012,19 +2021,18 @@ TclGlob(interp, pattern, unquotedPrefix, globFlags, types)
 	
 	c = *tail;
 	*tail = '\0';
-	head = DoTildeSubst(interp, start+1, &buffer);
+	if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) {
+	    /* 
+	     * We will ignore any error message here, and we
+	     * don't want to mess up the interpreter's result.
+	     */
+	    head = DoTildeSubst(NULL, start+1, &buffer);
+	} else {
+	    head = DoTildeSubst(interp, start+1, &buffer);
+	}
 	*tail = c;
 	if (head == NULL) {
 	    if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) {
-		/*
-		 * We should in fact pass down the nocomplain flag 
-		 * or save the interp result or use another mechanism
-		 * so the interp result is not mangled on errors in that case.
-		 * but that would a bigger change than reasonable for a patch
-		 * release.
-		 * (see fileName.test 15.2-15.4 for expected behaviour)
-		 */
-		Tcl_ResetResult(interp);
 		return TCL_OK;
 	    } else {
 		return TCL_ERROR;
@@ -2066,16 +2074,28 @@ TclGlob(interp, pattern, unquotedPrefix, globFlags, types)
 	}
     }
 
+    /* 
+     * We need to get the old result, in case it is over-written
+     * below when we still need it.
+     */
+    oldResult = Tcl_GetObjResult(interp);
+    Tcl_IncrRefCount(oldResult);
+    Tcl_ResetResult(interp);
+    
     result = TclDoGlob(interp, separators, &buffer, tail, types);
     Tcl_DStringFree(&buffer);
     
     if (result != TCL_OK) {
 	if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) {
-	    Tcl_ResetResult(interp);
-	    return TCL_OK;
+	    /* Put back the old result and reset the return code */
+	    Tcl_SetObjResult(interp, oldResult);
+	    result = TCL_OK;
 	}
     } else {
 	/* 
+	 * Now we must concatenate the 'oldResult' and the current
+	 * result, and then place that into the interpreter.
+	 * 
 	 * If we only want the tails, we must strip off the prefix now.
 	 * It may seem more efficient to pass the tails flag down into
 	 * TclDoGlob, Tcl_FSMatchInDirectory, but those functions are
@@ -2084,33 +2104,47 @@ TclGlob(interp, pattern, unquotedPrefix, globFlags, types)
 	 * complexity to the code.  This way is a little slower (when
 	 * the -tails flag is given), but much simpler to code.
 	 */
-	if (globFlags & TCL_GLOBMODE_TAILS) {
-	    int objc, i;
-	    Tcl_Obj **objv;
-	    Tcl_Obj *tailResult;
-	    Tcl_ListObjGetElements(NULL, Tcl_GetObjResult(interp), 
-				   &objc, &objv);
-	    tailResult = Tcl_NewListObj(0,NULL);
-	    for (i = 0; i< objc; i++) {
+	int objc, i;
+	Tcl_Obj **objv;
+
+	/* Ensure sole ownership */
+	if (Tcl_IsShared(oldResult)) {
+	    Tcl_DecrRefCount(oldResult);
+	    oldResult = Tcl_DuplicateObj(oldResult);
+	    Tcl_IncrRefCount(oldResult);
+	}
+
+	Tcl_ListObjGetElements(NULL, Tcl_GetObjResult(interp), 
+			       &objc, &objv);
+	for (i = 0; i< objc; i++) {
+	    Tcl_Obj* elt;
+	    if (globFlags & TCL_GLOBMODE_TAILS) {
 		int len;
 		char *oldStr = Tcl_GetStringFromObj(objv[i],&len);
-		Tcl_Obj* str;
 		if (len == prefixLen) {
 		    if ((pattern[0] == '\0')
 			|| (strchr(separators, pattern[0]) == NULL)) {
-			str = Tcl_NewStringObj(".",1);
+			elt = Tcl_NewStringObj(".",1);
 		    } else {
-			str = Tcl_NewStringObj("/",1);
+			elt = Tcl_NewStringObj("/",1);
 		    }
 		} else {
-		    str = Tcl_NewStringObj(oldStr + prefixLen, 
+		    elt = Tcl_NewStringObj(oldStr + prefixLen, 
 						len - prefixLen);
 		}
-		Tcl_ListObjAppendElement(interp, tailResult, str);
+	    } else {
+		elt = objv[i];
 	    }
-	    Tcl_SetObjResult(interp, tailResult);
+	    /* Assumption that 'oldResult' is a valid list */
+	    Tcl_ListObjAppendElement(interp, oldResult, elt);
 	}
+	Tcl_SetObjResult(interp, oldResult);
     }
+    /* 
+     * Release our temporary copy.  All code paths above must
+     * end here so we free our reference.
+     */
+    Tcl_DecrRefCount(oldResult);
     return result;
 }
 
diff --git a/tests/fileName.test b/tests/fileName.test
index 3785709..cdf3572 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.21 2002/05/08 05:58:56 dgp Exp $
+# RCS: @(#) $Id: fileName.test,v 1.22 2002/05/30 09:27:11 vincentdarley Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -1227,6 +1227,13 @@ test filename-11.17.4 {Tcl_GlobCmd} {unixOnly notRoot} {
     file delete [file join $globname link]
     set ret
 } [list 0 [list [file join $globname link]]]
+test filename-11.17.5 {Tcl_GlobCmd} {
+    list [catch {lsort [glob -directory $globname -tails *.c]} msg] $msg
+} [list 0 [lsort [list "weird name.c" x,z1.c x1.c y1.c z1.c]]]
+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.18 {Tcl_GlobCmd} {unixOnly} {
     list [catch {lsort [glob -path $globname/ *]} msg] $msg
 } [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\
@@ -1676,7 +1683,7 @@ test filename-15.2 {unix specific no complain: no errors} {unixOnly nonPortable}
     glob -nocomplain globTest/a1/*
 } {}
 test filename-15.3 {unix specific no complain: no errors, good result} \
-	{unixOnly nonPortable knownBug} {
+	{unixOnly nonPortable} {
     # test fails because if an error occur , the interp's result
     # is reset...
     glob -nocomplain globTest/a2 globTest/a1/* globTest/a3
@@ -1684,12 +1691,18 @@ test filename-15.3 {unix specific no complain: no errors, good result} \
 
 catch {exec chmod 755 globTest/a1}
 test filename-15.4 {unix specific no complain: no errors, good result} \
-	{unixOnly nonPortable knownBug} {
+	{unixOnly nonPortable} {
     # test fails because if an error occurs, the interp's result
     # is reset... or you don't run at scriptics where the
     # outser and welch users exists
     glob -nocomplain ~ouster ~foo ~welch
 } {/home/ouster /home/welch}
+test filename-15.4.1 {no complain: no errors, good result} {
+    # test used to fail because if an error occurs, the interp's result
+    # is reset... 
+    string equal [glob -nocomplain ~wontexist ~blah ~] \
+      [glob -nocomplain ~ ~blah ~wontexist]
+} {1}
 test filename-15.5 {unix specific globbing} {unixOnly nonPortable} {
     glob ~ouster/.csh*
 } "/home/ouster/.cshrc"