diff options
| -rw-r--r-- | ChangeLog | 16 | ||||
| -rw-r--r-- | doc/FileSystem.3 | 5 | ||||
| -rw-r--r-- | generic/tclFileName.c | 59 | ||||
| -rw-r--r-- | tests/fileName.test | 23 |
4 files changed, 63 insertions, 40 deletions
@@ -1,5 +1,21 @@ 2006-03-18 Vince Darley <vincentdarley@sourceforge.net> + * generic/tclFileName.c: + * doc/FileSystem.3: + * tests/fileName.test: Fix to [Bug 1084705] so that + 'glob -nocomplain' finally agrees with its documentation and + doesn't swallow genuine errors. + + ***POTENTIAL INCOMPATIBILITY*** for scripts that assumed + '-nocomplain' removes the need for 'catch' to deal with + non-understood path names. + + Small optimisation to implementation of pattern==NULL case + of TclGlob, and clarification to the documentation + [Tclvfs bug 1405317] + +2006-03-18 Vince Darley <vincentdarley@sourceforge.net> + * tests/fCmd.test: added knownBug test case for [Bug 1394972] * tests/winFCmd.test: diff --git a/doc/FileSystem.3 b/doc/FileSystem.3 index 3aee462..9ba51ab 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.55 2005/08/31 15:12:18 vincentdarley Exp $ +'\" RCS: @(#) $Id: FileSystem.3,v 1.56 2006/03/19 23:04:23 vincentdarley Exp $ '\" .so man.macros .TH Filesystem 3 8.4 Tcl "Tcl Library Procedures" @@ -384,7 +384,8 @@ Note that the \fBglob\fR code implements recursive patterns internally, so this function will only ever be passed simple patterns, which can be matched using the logic of \fBstring match\fR. To handle recursion, Tcl will call this function frequently asking only for directories to be -returned. +returned. A special case of being called with a NULL pattern indicates +that the path needs to be checked only for the correct type. .PP \fBTcl_FSLink\fR replaces the library version of \fBreadlink\fR, and extends it to support the creation of links. The appropriate function diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 46462ff..27af639 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.73 2005/10/23 18:51:31 vincentdarley Exp $ + * RCS: @(#) $Id: tclFileName.c,v 1.74 2006/03/19 23:04:23 vincentdarley Exp $ */ #include "tclInt.h" @@ -1610,9 +1610,7 @@ Tcl_GlobObjCmd( * occurred in globbing. After a normal return the result in interp (set * by DoGlob) holds all of the file names given by the pattern and * pathPrefix arguments. After an 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. + * an error message. * * Side effects: * The 'pattern' is written to. @@ -1681,22 +1679,10 @@ TclGlob( c = *tail; *tail = '\0'; - 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); - } + head = DoTildeSubst(interp, start+1, &buffer); *tail = c; if (head == NULL) { - if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) { - return TCL_OK; - } else { - return TCL_ERROR; - } + return TCL_ERROR; } if (head != Tcl_DStringValue(&buffer)) { Tcl_DStringAppend(&buffer, head, -1); @@ -1773,11 +1759,7 @@ TclGlob( if (cwd == NULL) { Tcl_DecrRefCount(temp); - if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) { - return TCL_OK; - } else { - return TCL_ERROR; - } + return TCL_ERROR; } pathPrefix = Tcl_NewStringObj(Tcl_GetString(cwd), 3); Tcl_DecrRefCount(cwd); @@ -1854,10 +1836,30 @@ TclGlob( if (*tail == '\0' && pathPrefix != NULL) { /* - * An empty pattern + * An empty pattern. This means 'pathPrefix' is actually + * a full path of a file/directory we want to simply check + * for existence and type. */ - result = Tcl_FSMatchInDirectory(interp, filenamesObj, pathPrefix, - NULL, types); + if (types == NULL) { + /* + * We just want to check for existence. In this case we + * make it easy on Tcl_FSMatchInDirectory and its + * sub-implementations by not bothering them (even though + * they should support this situation) and we just use the + * simple existence check with Tcl_FSAccess. + */ + if (Tcl_FSAccess(pathPrefix, F_OK) == 0) { + Tcl_ListObjAppendElement(interp, filenamesObj, pathPrefix); + } + result = TCL_OK; + } else { + /* + * We want to check for the correct type. Tcl_FSMatchInDirectory + * is documented to do this for us, if we give it a NULL pattern. + */ + result = Tcl_FSMatchInDirectory(interp, filenamesObj, pathPrefix, + NULL, types); + } } else { result = DoGlob(interp, filenamesObj, separators, pathPrefix, globFlags & TCL_GLOBMODE_DIR, tail, types); @@ -1869,11 +1871,6 @@ TclGlob( if (result != TCL_OK) { TclDecrRefCount(filenamesObj); - if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) { - /* Put back the old result and reset the return code */ - Tcl_SetObjResult(interp, savedResultObj); - result = TCL_OK; - } TclDecrRefCount(savedResultObj); if (pathPrefix != NULL) { Tcl_DecrRefCount(pathPrefix); diff --git a/tests/fileName.test b/tests/fileName.test index c2d870c..5e4286e 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.49 2005/10/12 22:05:46 dkf Exp $ +# RCS: @(#) $Id: fileName.test,v 1.50 2006/03/19 23:04:24 vincentdarley Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -689,8 +689,8 @@ test filename-11.4 {Tcl_GlobCmd} { list [catch {glob -nocomplain} msg] $msg } {1 {wrong # args: should be "glob ?switches? name ?name ...?"}} test filename-11.5 {Tcl_GlobCmd} { - list [catch {glob -nocomplain ~xyqrszzz} msg] $msg -} {0 {}} + list [catch {glob -nocomplain * ~xyqrszzz} msg] $msg +} {1 {user "xyqrszzz" doesn't exist}} test filename-11.6 {Tcl_GlobCmd} { list [catch {glob ~xyqrszzz} msg] $msg } {1 {user "xyqrszzz" doesn't exist}} @@ -707,7 +707,7 @@ test filename-11.9 {Tcl_GlobCmd} {testsetplatform} { test filename-11.10 {Tcl_GlobCmd} {testsetplatform} { testsetplatform unix list [catch {glob -nocomplain ~\\xyqrszzz/bar} msg] $msg -} {0 {}} +} {1 {user "\xyqrszzz" doesn't exist}} test filename-11.11 {Tcl_GlobCmd} {testsetplatform} { testsetplatform unix list [catch {glob ~xyqrszzz\\/\\bar} msg] $msg @@ -1370,11 +1370,20 @@ test filename-15.4 {unix specific no complain: no errors, good result} \ # 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 filename-15.4.1 {no complain: errors, sequencing} { + # test used to fail because if an error occurs, the interp's result + # is reset... But, the sequence means we throw a different error + # first. + concat \ + [list [catch {glob -nocomplain ~wontexist ~blahxyz ~} res1] $res1] \ + [list [catch {glob -nocomplain ~ ~blahxyz ~wontexist} res2] $res2] +} {1 {user "wontexist" doesn't exist} 1 {user "blahxyz" doesn't exist}} +test filename-15.4.2 {no complain: errors, sequencing} { # 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] + string equal \ + [list [catch {glob -nocomplain ~wontexist *} res1] $res1] \ + [list [catch {glob -nocomplain * ~wontexist} res2] $res2] } {1} test filename-15.5 {unix specific globbing} {unix nonPortable} { glob ~ouster/.csh* |